matchable (empty) → 0.1.1.1
raw patch · 7 files changed
+559/−0 lines, 7 filesdep +Globdep +basedep +containers
Dependencies added: Glob, base, containers, doctest, doctest-discover, hashable, hspec, matchable, tagged, unordered-containers, vector
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- README.md +19/−0
- matchable.cabal +54/−0
- src/Data/Matchable.hs +326/−0
- test/doctest.hs +8/−0
- test/example.hs +118/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# 0.1.1.1++- Initial release.+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Koji Miyazato (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Koji Miyazato nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,19 @@+## matchable++This package provides a type class `Matchable`, which represents+`zipMatch` operation which can zip two values.++`zipMatch` operation can fail, and it returns zipped value wrapped+in `Maybe`. Specifically, `zipMatch` returns zipped value if and only if two arguments+have exactly same shape.++### Example++``` haskell+>>> zipMatch [1,2] ['a','b']+Just [(1,'a'), (2,'b')]+>>> zipMatch [1,2,3] ['a','b']+Nothing+```++See [example](https://github.com/viercc/matchable/blob/master/example/README.md) also.
+ matchable.cabal view
@@ -0,0 +1,54 @@+name: matchable+version: 0.1.1.1+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+ exactly same shape.+license: BSD3+license-file: LICENSE+author: Koji Miyazato+maintainer: viercc@gmail.com+category: Functors+build-type: Simple+extra-source-files: README.md, CHANGELOG.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/viercc/matchable+ branch: master++library+ hs-source-dirs: src+ exposed-modules: Data.Matchable+ build-depends: base >=4.10 && <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+ 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+ ghc-options: -Wall+ default-language: Haskell2010+
+ src/Data/Matchable.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}+module Data.Matchable(+ -- * Matchable class+ Matchable(..),+ zipzipMatch,+ fmapRecovered,+ eqDefault,+ liftEqDefault,++ -- * Define Matchable by Generic+ Matchable'(), genericZipMatchWith,+) where++import Control.Applicative++import Data.Functor.Classes++import Data.Maybe (fromMaybe, isJust)+import Data.Foldable++import Data.Functor.Identity+import Data.Functor.Compose+import Data.Functor.Product+import Data.Functor.Sum++import Data.Tagged+import Data.Proxy++import Data.List.NonEmpty (NonEmpty)++import Data.Map.Lazy (Map)+import qualified Data.Map.Lazy as Map+import Data.IntMap.Lazy (IntMap)+import qualified Data.IntMap.Merge.Lazy as IntMap+import Data.Tree (Tree)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq++import Data.Vector (Vector)+import qualified Data.Vector as Vector++import Data.Hashable (Hashable)+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++import GHC.Generics++-- | Containers that allows exact structural matching of two containers.+class (Eq1 t, Functor t) => Matchable t where+ {- |+ Decides if two structures match exactly. If they match, return zipped version of them.++ > zipMatch ta tb = Just tab++ holds if and only if both of++ > ta = fmap fst tab+ > tb = fmap snd tab++ holds. Otherwise, @zipMatch ta tb = Nothing@.++ For example, the type signature of @zipMatch@ on the list Functor @[]@ reads as follows:++ > zipMatch :: [a] -> [b] -> Maybe [(a,b)]++ @zipMatch as bs@ returns @Just (zip as bs)@ if the lengths of two given lists are+ same, and returns @Nothing@ otherwise.++ ==== Example+ >>> zipMatch [1, 2, 3] ['a', 'b', 'c']+ Just [(1,'a'),(2,'b'),(3,'c')]+ >>> zipMatch [1, 2, 3] ['a', 'b']+ Nothing+ -}+ zipMatch :: t a -> t b -> Maybe (t (a,b))+ zipMatch = zipMatchWith (curry Just)++ {- |+ Match two structures. If they match, zip them with given function+ @(a -> b -> Maybe c)@. Passed function can make whole match fail+ by returning @Nothing@.++ A definition of 'zipMatchWith' must satisfy:++ * If there is a pair @(tab, tc)@ such that fulfills all following three conditions,+ then @zipMatchWith f ta tb = Just tc@.++ 1. @ta = fmap fst tab@+ 2. @tb = fmap snd tab@+ 3. @fmap (uncurry f) tab = fmap Just tc@++ * If there are no such pair, @zipMatchWith f ta tb = Nothing@.++ If @t@ is also 'Traversable', the last condition can be dropped and+ the equation can be stated without using @tc@.++ > zipMatchWith f ta tb = traverse (uncurry f) tab+ + @zipMatch@ can be defined in terms of @zipMatchWith@.+ And if @t@ is also @Traversable@, @zipMatchWith@ can be defined in terms of @zipMatch@.+ When you implement both of them by hand, keep their relation in the way+ the default implementation is.++ > zipMatch = zipMatchWith (curry pure)+ > zipMatchWith f ta tb = zipMatch ta tb >>= traverse (uncurry f)++ -}+ zipMatchWith :: (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)++ {-# MINIMAL zipMatchWith #-}++-- | > zipzipMatch = zipMatchWith zipMatch+zipzipMatch+ :: (Matchable t, Matchable u)+ => t (u a)+ -> t (u b)+ -> Maybe (t (u (a, b)))+zipzipMatch = zipMatchWith zipMatch++-- | @Matchable t@ implies @Functor t@.+-- It is not recommended to implement @fmap@ through this function,+-- so it is named @fmapRecovered@ but not @fmapDefault@.+fmapRecovered :: (Matchable t) => (a -> b) -> t a -> t b+fmapRecovered f ta =+ fromMaybe (error "Law-violating Matchable instance") $+ zipMatchWith (\a _ -> Just (f a)) ta ta++-- | @Matchable t@ implies @Eq a => Eq (t a)@.+eqDefault :: (Matchable t, Eq a) => t a -> t a -> Bool+eqDefault = liftEqDefault (==)++-- | @Matchable t@ implies @Eq1 t@.+liftEqDefault :: (Matchable t) => (a -> b -> Bool) -> t a -> t b -> Bool+liftEqDefault eq tx ty =+ let u x y = if x `eq` y then Just () else Nothing+ in isJust $ zipMatchWith u tx ty++-----------------------------------------------++instance Matchable Identity where+ zipMatchWith = genericZipMatchWith++instance (Eq k) => Matchable (Const k) where+ zipMatchWith = genericZipMatchWith++instance (Matchable f, Matchable g) => Matchable (Product f g) where+ zipMatchWith = genericZipMatchWith++instance (Matchable f, Matchable g) => Matchable (Sum f g) where+ zipMatchWith = genericZipMatchWith++instance (Matchable f, Matchable g) => Matchable (Compose f g) where+ zipMatchWith = genericZipMatchWith++instance Matchable Proxy where+ zipMatchWith _ _ _ = Just Proxy++instance Matchable (Tagged t) where+ zipMatchWith = genericZipMatchWith++instance Matchable Maybe where+ zipMatchWith = genericZipMatchWith++instance Matchable [] where+ zipMatchWith = genericZipMatchWith++instance Matchable NonEmpty where+ zipMatchWith = genericZipMatchWith++instance (Eq e) => Matchable ((,) e) where+ zipMatchWith = genericZipMatchWith++instance (Eq e) => Matchable (Either e) where+ zipMatchWith = genericZipMatchWith++instance (Eq k) => Matchable (Map k) where+ zipMatchWith u ma mb =+ Map.fromAscList <$> zipMatchWith (zipMatchWith u) (Map.toAscList ma) (Map.toAscList mb)++instance Matchable IntMap where+ zipMatchWith u =+ IntMap.mergeA (IntMap.traverseMissing (\_ _ -> Nothing))+ (IntMap.traverseMissing (\_ _ -> Nothing))+ (IntMap.zipWithAMatched (const u))++instance Matchable Tree where+ zipMatchWith = genericZipMatchWith++instance Matchable Seq where+ zipMatch as bs+ | Seq.length as == Seq.length bs = Just (Seq.zip as bs)+ | otherwise = Nothing+ zipMatchWith u as bs+ | Seq.length as == Seq.length bs = unsafeFillIn u as (Data.Foldable.toList bs)+ | otherwise = Nothing++instance Matchable Vector where+ zipMatch as bs+ | Vector.length as == Vector.length bs = Just (Vector.zip as bs)+ | otherwise = Nothing++ zipMatchWith u as bs+ | Vector.length as == Vector.length bs = Vector.zipWithM u as bs+ | otherwise = Nothing++instance (Eq k, Hashable k) => Matchable (HashMap k) where+ zipMatch as bs+ | HashMap.size as == HashMap.size bs =+ HashMap.traverseWithKey (\k a -> (,) a <$> HashMap.lookup k bs) as+ | otherwise = Nothing+ zipMatchWith u as bs+ | HashMap.size as == HashMap.size bs =+ HashMap.traverseWithKey (\k a -> u a =<< HashMap.lookup k bs) as+ | otherwise = Nothing++-- * Generic definition++{-|++An instance of Matchable can be implemened through GHC Generics.+You only need to do two things: Make your type @Functor@ and @Generic1@.++==== Example+>>> :set -XDeriveFunctor+>>> :set -XDeriveGeneric+>>> :{+ data MyTree label a = Leaf a | Node label [MyTree label a]+ deriving (Show, Read, Eq, Ord, Functor, Generic1)+:}++Then you can use @genericZipMatchWith@ to implement @zipMatchWith@ method.+You also need @Eq1@ instance, but 'liftEqDefault' is provided.++>>> :{+ instance (Eq label) => Matchable (MyTree label) where+ zipMatchWith = genericZipMatchWith+ instance (Eq label) => Eq1 (MyTree label) where+ liftEq = liftEqDefault+ :}++>>> zipMatch (Node "foo" [Leaf 1, Leaf 2]) (Node "foo" [Leaf 'a', Leaf 'b'])+Just (Node "foo" [Leaf (1,'a'),Leaf (2,'b')])+>>> zipMatch (Node "foo" [Leaf 1, Leaf 2]) (Node "bar" [Leaf 'a', Leaf 'b'])+Nothing+>>> zipMatch (Node "foo" [Leaf 1]) (Node "foo" [])+Nothing++-}+class Matchable' t where+ zipMatchWith' :: (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)++-- | zipMatchWith via Generics.+genericZipMatchWith+ :: (Generic1 t, Matchable' (Rep1 t))+ => (a -> b -> Maybe c)+ -> t a+ -> t b+ -> Maybe (t c)+genericZipMatchWith u ta tb = to1 <$> zipMatchWith' u (from1 ta) (from1 tb)+{-# INLINABLE genericZipMatchWith #-}++instance Matchable' V1 where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' _ a _ = case a of { }++instance Matchable' U1 where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' _ _ _ = pure U1++instance Matchable' Par1 where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (Par1 a) (Par1 b) = Par1 <$> u a b++instance Matchable f => Matchable' (Rec1 f) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (Rec1 fa) (Rec1 fb) = Rec1 <$> zipMatchWith u fa fb++instance (Eq c) => Matchable' (K1 i c) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' _ (K1 ca) (K1 cb)+ = if ca == cb then pure (K1 ca) else empty++instance Matchable' f => Matchable' (M1 i c f) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (M1 fa) (M1 fb) = M1 <$> zipMatchWith' u fa fb++instance (Matchable' f, Matchable' g) => Matchable' (f :+: g) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (L1 fa) (L1 fb) = L1 <$> zipMatchWith' u fa fb+ zipMatchWith' u (R1 ga) (R1 gb) = R1 <$> zipMatchWith' u ga gb+ zipMatchWith' _ _ _ = empty++instance (Matchable' f, Matchable' g) => Matchable' (f :*: g) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (fa :*: ga) (fb :*: gb) =+ liftA2 (:*:) (zipMatchWith' u fa fb) (zipMatchWith' u ga gb)++instance (Matchable f, Matchable' g) => Matchable' (f :.: g) where+ {-# INLINABLE zipMatchWith' #-}+ zipMatchWith' u (Comp1 fga) (Comp1 fgb) =+ Comp1 <$> zipMatchWith (zipMatchWith' u) fga fgb++-- Utility functions++unsafeFillIn :: (Traversable f) => (a -> b -> Maybe c) -> f a -> [b] -> Maybe (f c)+unsafeFillIn u as bs = fst <$> runFillIn (traverse (useOne u) as) bs++-- Just a @StateT [b] Maybe@ but avoids to depend on transformers+newtype FillIn b a = FillIn { runFillIn :: [b] -> Maybe (a, [b]) }+ deriving (Functor)++instance Applicative (FillIn b) where+ pure a = FillIn $ \bs -> Just (a, bs)+ FillIn fx <*> FillIn fy = FillIn $ \bs ->+ fx bs >>= \(x, bs') ->+ fy bs' >>= \(y, bs'') -> Just (x y, bs'')++useOne :: (a -> b -> Maybe c) -> a -> FillIn b c+useOne u a = FillIn $ \bs -> case bs of+ [] -> Nothing+ (b:bs') -> u a b >>= \c -> Just (c, bs')+
+ test/doctest.hs view
@@ -0,0 +1,8 @@+module Main where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = do+ glob "src/**/*.hs" >>= doctest
+ test/example.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+module Main(main) where++import Data.Matchable+import qualified Data.Map as Map++import GHC.Generics(Generic1)+import Data.Functor.Classes++import Test.Hspec++main :: IO ()+main = hspec $+ do context "Matchable []" $ do+ runIO $ do+ p $ "list1 = " ++ show list1+ p $ "list2 = " ++ show list2+ p $ "list3 = " ++ show list3+ p "list4 = repeat 0"+ specify "zipMatch list1 list2 = Just [(0,3), (1,4), (2,5)]" $+ zipMatch list1 list2 `shouldBe` Just [(0,3), (1,4), (2,5)]+ specify "zipMatch list1 list3 = Nothing" $+ zipMatch list1 list3 `shouldBe` Nothing+ specify "zipMatch list1 list4 = Nothing" $+ zipMatch list1 list4 `shouldBe` Nothing+ context "Matchable (Either String)" $ do+ runIO $ do+ p $ "either1 = " ++ show either1+ p $ "either2 = " ++ show either2+ p $ "either3 = " ++ show either3+ p $ "either4 = " ++ show either4+ specify "zipMatch either1 either2 = Just (Right (1,2))" $+ zipMatch either1 either2 `shouldBe` Just (Right (1,2))+ specify "zipMatch either1 either3 = Nothing" $+ zipMatch either1 either3 `shouldBe` Nothing+ specify "zipMatch either3 either3 = Just (Left \"foo\")" $+ zipMatch either3 either3 `shouldBe` Just (Left "foo")+ specify "zipMatch either3 either4 = Nothing" $+ zipMatch either3 either4 `shouldBe` Nothing+ context "Matchable ((,) Char)" $ do+ runIO $ do+ p $ "pair1 = " ++ show pair1+ p $ "pair2 = " ++ show pair2+ p $ "pair3 = " ++ show pair3+ p $ "pair4 = " ++ show pair4+ specify "zipMatch pair1 pair2 = Just ('a', (1,2))" $+ zipMatch pair1 pair2 `shouldBe` Just ('a', (1,2))+ specify "zipMatch pair3 pair4 = Just ('b', (3,4))" $+ zipMatch pair3 pair4 `shouldBe` Just ('b', (3,4))+ specify "zipMatch pair1 pair3 = Nothing" $+ zipMatch pair1 pair3 `shouldBe` Nothing+ context "Matchable (Map Char)" $ do+ runIO $ do+ p $ "map1 = " ++ show map1+ p $ "map2 = " ++ show map2+ p $ "map3 = " ++ show map3+ specify "zipMatch map1 map2 = Just (Map.fromList [('a', (1,2)), ('b', (3,4))])" $+ zipMatch map1 map2 `shouldBe` Just (Map.fromList [('a', (1,2)), ('b', (3,4))])+ specify "zipMatch map1 map3 = Nothing" $+ zipMatch map1 map3 `shouldBe` Nothing+ context "Matchable (MyTree Int)" $ do+ runIO $ do+ p $ "myTree1 = " ++ show myTree1+ p $ "myTree2 = " ++ show myTree2+ p $ "myTree3 = " ++ show myTree3+ p $ "myTree4 = " ++ show myTree4+ specify "zipMatch myTree1 myTree2 = Just _" $+ zipMatch myTree1 myTree2 `shouldBe` Just (Node 0 ("foo",200) Empty (Node 1 ("bar", 300) Empty Empty))+ specify "zipMatch myTree1 myTree3 = Nothing" $+ zipMatch myTree1 myTree3 `shouldBe` Nothing+ specify "zipMatch myTree1 myTree4 = Nothing" $+ zipMatch myTree1 myTree4 `shouldBe` Nothing+ where p = putStrLn++list1, list2, list3, list4 :: [Int]+list1 = [0,1,2]+list2 = [3,4,5]+list3 = [0,1]+list4 = repeat 0++either1, either2, either3, either4 :: Either String Int+either1 = Right 1+either2 = Right 2+either3 = Left "foo"+either4 = Left "bar"++pair1, pair2, pair3, pair4 :: (Char, Int)+pair1 = ('a', 1)+pair2 = ('a', 2)+pair3 = ('b', 3)+pair4 = ('b', 4)++map1, map2, map3 :: Map.Map Char Int+map1 = Map.fromList [pair1, pair3]+map2 = Map.fromList [pair2, pair4]+map3 = Map.fromList [pair1]++data MyTree k a = Empty | Node k a (MyTree k a) (MyTree k a)+ deriving (Show, Eq, Functor, Generic1)++instance Eq k => Eq1 (MyTree k) where+ liftEq = liftEqDefault++instance Eq k => Matchable (MyTree k) where+ zipMatchWith = genericZipMatchWith++myTree1 :: MyTree Int String+myTree1 = Node 0 "foo" Empty (Node 1 "bar" Empty Empty)++myTree2 :: MyTree Int Int+myTree2 = Node 0 200 Empty (Node 1 300 Empty Empty)++myTree3 :: MyTree Int Bool+myTree3 = Node 3 True Empty (Node 4 False Empty Empty)++myTree4 :: MyTree Int Char+myTree4 = Node 0 'a' Empty Empty