{-# LANGUAGE EmptyCase        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE TypeOperators    #-}
{-# LANGUAGE DeriveFunctor    #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Matchable(
  -- * Matchable class
  Matchable(..),
  zipzipMatch,
  fmapRecovered,
  eqDefault,
  liftEqDefault,

  -- * Define Matchable by Generic
  Matchable'(), genericZipMatchWith,
) where

import           Control.Applicative

import Data.Functor.Classes ( Eq1 )
import Data.Orphans()

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.Lazy       as 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
    ( Generic1(..),
      V1,
      U1(..),
      Par1(Par1),
      Rec1(Rec1),
      K1(K1),
      M1(M1),
      type (:+:)(..),
      type (:*:)(..),
      type (:.:)(Comp1) )
import GHC.Generics.Generically ( Generically1(..) )

-- $setup
-- This is required to silence "type defaults" warning, which clutters GHCi
-- output and makes doctests fail.
-- >>> :set -Wno-type-defaults

-- | 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 = (a -> b -> Maybe (a, b)) -> t a -> t b -> Maybe (t (a, b))
forall a b c. (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (((a, b) -> Maybe (a, b)) -> a -> b -> Maybe (a, b)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
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 :: forall (t :: * -> *) (u :: * -> *) a b.
(Matchable t, Matchable u) =>
t (u a) -> t (u b) -> Maybe (t (u (a, b)))
zipzipMatch = (u a -> u b -> Maybe (u (a, b)))
-> t (u a) -> t (u b) -> Maybe (t (u (a, b)))
forall a b c. (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith u a -> u b -> Maybe (u (a, b))
forall a b. u a -> u b -> Maybe (u (a, b))
forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
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 :: forall (t :: * -> *) a b. Matchable t => (a -> b) -> t a -> t b
fmapRecovered a -> b
f t a
ta =
  t b -> Maybe (t b) -> t b
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> t b
forall a. HasCallStack => [Char] -> a
error [Char]
"Law-violating Matchable instance") (Maybe (t b) -> t b) -> Maybe (t b) -> t b
forall a b. (a -> b) -> a -> b
$
    (a -> a -> Maybe b) -> t a -> t a -> Maybe (t b)
forall a b c. (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (\a
a a
_ -> b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
f a
a)) t a
ta t a
ta

-- | @Matchable t@ implies @Eq a => Eq (t a)@.
eqDefault :: (Matchable t, Eq a) => t a -> t a -> Bool
eqDefault :: forall (t :: * -> *) a. (Matchable t, Eq a) => t a -> t a -> Bool
eqDefault = (a -> a -> Bool) -> t a -> t a -> Bool
forall (t :: * -> *) a b.
Matchable t =>
(a -> b -> Bool) -> t a -> t b -> Bool
liftEqDefault a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | @Matchable t@ implies @Eq1 t@.
liftEqDefault :: (Matchable t) => (a -> b -> Bool) -> t a -> t b -> Bool
liftEqDefault :: forall (t :: * -> *) a b.
Matchable t =>
(a -> b -> Bool) -> t a -> t b -> Bool
liftEqDefault a -> b -> Bool
eq t a
tx t b
ty =
  let u :: a -> b -> Maybe ()
u a
x b
y = if a
x a -> b -> Bool
`eq` b
y then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing
  in Maybe (t ()) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (t ()) -> Bool) -> Maybe (t ()) -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> b -> Maybe ()) -> t a -> t b -> Maybe (t ())
forall a b c. (a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith a -> b -> Maybe ()
u t a
tx t b
ty

-----------------------------------------------

instance Matchable Identity where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Identity a -> Identity b -> Maybe (Identity c)
zipMatchWith = (a -> b -> Maybe c)
-> Identity a -> Identity b -> Maybe (Identity c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Eq k) => Matchable (Const k) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Const k a -> Const k b -> Maybe (Const k c)
zipMatchWith = (a -> b -> Maybe c) -> Const k a -> Const k b -> Maybe (Const k c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Matchable f, Matchable g) => Matchable (Product f g) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Product f g a -> Product f g b -> Maybe (Product f g c)
zipMatchWith = (a -> b -> Maybe c)
-> Product f g a -> Product f g b -> Maybe (Product f g c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Matchable f, Matchable g) => Matchable (Sum f g) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Sum f g a -> Sum f g b -> Maybe (Sum f g c)
zipMatchWith = (a -> b -> Maybe c) -> Sum f g a -> Sum f g b -> Maybe (Sum f g c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Matchable f, Matchable g) => Matchable (Compose f g) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Compose f g a -> Compose f g b -> Maybe (Compose f g c)
zipMatchWith = (a -> b -> Maybe c)
-> Compose f g a -> Compose f g b -> Maybe (Compose f g c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable Proxy where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Proxy a -> Proxy b -> Maybe (Proxy c)
zipMatchWith a -> b -> Maybe c
_ Proxy a
_ Proxy b
_ = Proxy c -> Maybe (Proxy c)
forall a. a -> Maybe a
Just Proxy c
forall {k} (t :: k). Proxy t
Proxy

instance Matchable (Tagged t) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Tagged t a -> Tagged t b -> Maybe (Tagged t c)
zipMatchWith = (a -> b -> Maybe c)
-> Tagged t a -> Tagged t b -> Maybe (Tagged t c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable Maybe where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe (Maybe c)
zipMatchWith = (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe (Maybe c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable [] where
  zipMatchWith :: forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
zipMatchWith = (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable NonEmpty where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> NonEmpty a -> NonEmpty b -> Maybe (NonEmpty c)
zipMatchWith = (a -> b -> Maybe c)
-> NonEmpty a -> NonEmpty b -> Maybe (NonEmpty c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Eq e) => Matchable ((,) e) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> (e, a) -> (e, b) -> Maybe (e, c)
zipMatchWith = (a -> b -> Maybe c) -> (e, a) -> (e, b) -> Maybe (e, c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance (Eq e) => Matchable (Either e) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Either e a -> Either e b -> Maybe (Either e c)
zipMatchWith = (a -> b -> Maybe c)
-> Either e a -> Either e b -> Maybe (Either e c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable Seq where
  zipMatch :: forall a b. Seq a -> Seq b -> Maybe (Seq (a, b))
zipMatch Seq a
as Seq b
bs
    | Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq b -> Int
forall a. Seq a -> Int
Seq.length Seq b
bs = Seq (a, b) -> Maybe (Seq (a, b))
forall a. a -> Maybe a
Just (Seq a -> Seq b -> Seq (a, b)
forall a b. Seq a -> Seq b -> Seq (a, b)
Seq.zip Seq a
as Seq b
bs)
    | Bool
otherwise                      = Maybe (Seq (a, b))
forall a. Maybe a
Nothing
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Seq a -> Seq b -> Maybe (Seq c)
zipMatchWith a -> b -> Maybe c
u Seq a
as Seq b
bs
    | Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq b -> Int
forall a. Seq a -> Int
Seq.length Seq b
bs = (a -> b -> Maybe c) -> Seq a -> [b] -> Maybe (Seq c)
forall (f :: * -> *) a b c.
Traversable f =>
(a -> b -> Maybe c) -> f a -> [b] -> Maybe (f c)
unsafeFillIn a -> b -> Maybe c
u Seq a
as (Seq b -> [b]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Seq b
bs)
    | Bool
otherwise                      = Maybe (Seq c)
forall a. Maybe a
Nothing

instance (Eq k) => Matchable (Map k) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Map k a -> Map k b -> Maybe (Map k c)
zipMatchWith a -> b -> Maybe c
u Map k a
as Map k b
bs
    | Map k a -> Int
forall k a. Map k a -> Int
Map.size Map k a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map k b -> Int
forall k a. Map k a -> Int
Map.size Map k b
bs =
        [(k, c)] -> Map k c
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(k, c)] -> Map k c) -> Maybe [(k, c)] -> Maybe (Map k c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          ((k, a) -> (k, b) -> Maybe (k, c))
-> [(k, a)] -> [(k, b)] -> Maybe [(k, c)]
forall a b c. (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c]
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith ((a -> b -> Maybe c) -> (k, a) -> (k, b) -> Maybe (k, c)
forall a b c.
(a -> b -> Maybe c) -> (k, a) -> (k, b) -> Maybe (k, c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith a -> b -> Maybe c
u) (Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k a
as) (Map k b -> [(k, b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k b
bs)
    | Bool
otherwise                  = Maybe (Map k c)
forall a. Maybe a
Nothing

instance Matchable IntMap where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> IntMap a -> IntMap b -> Maybe (IntMap c)
zipMatchWith a -> b -> Maybe c
u IntMap a
as IntMap b
bs
    | IntMap a -> Int
forall a. IntMap a -> Int
IntMap.size IntMap a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IntMap b -> Int
forall a. IntMap a -> Int
IntMap.size IntMap b
bs = IntMap a -> IntMap b -> Maybe (IntMap c)
merger IntMap a
as IntMap b
bs
    | Bool
otherwise = Maybe (IntMap c)
forall a. Maybe a
Nothing
    where
      miss :: WhenMissing Maybe x y
miss = (Int -> x -> Maybe y) -> WhenMissing Maybe x y
forall (f :: * -> *) x y.
Applicative f =>
(Int -> x -> f y) -> WhenMissing f x y
IntMap.traverseMissing (\Int
_ x
_ -> Maybe y
forall a. Maybe a
Nothing)
      merger :: IntMap a -> IntMap b -> Maybe (IntMap c)
merger = WhenMissing Maybe a c
-> WhenMissing Maybe b c
-> WhenMatched Maybe a b c
-> IntMap a
-> IntMap b
-> Maybe (IntMap c)
forall (f :: * -> *) a c b.
Applicative f =>
WhenMissing f a c
-> WhenMissing f b c
-> WhenMatched f a b c
-> IntMap a
-> IntMap b
-> f (IntMap c)
IntMap.mergeA WhenMissing Maybe a c
forall {x} {y}. WhenMissing Maybe x y
miss WhenMissing Maybe b c
forall {x} {y}. WhenMissing Maybe x y
miss ((Int -> a -> b -> Maybe c) -> WhenMatched Maybe a b c
forall (f :: * -> *) x y z.
Applicative f =>
(Int -> x -> y -> f z) -> WhenMatched f x y z
IntMap.zipWithAMatched ((a -> b -> Maybe c) -> Int -> a -> b -> Maybe c
forall a b. a -> b -> a
const a -> b -> Maybe c
u))

instance Matchable Tree where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Tree a -> Tree b -> Maybe (Tree c)
zipMatchWith = (a -> b -> Maybe c) -> Tree a -> Tree b -> Maybe (Tree c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith

instance Matchable Vector where
  zipMatch :: forall a b. Vector a -> Vector b -> Maybe (Vector (a, b))
zipMatch Vector a
as Vector b
bs
    | Vector a -> Int
forall a. Vector a -> Int
Vector.length Vector a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector b -> Int
forall a. Vector a -> Int
Vector.length Vector b
bs = Vector (a, b) -> Maybe (Vector (a, b))
forall a. a -> Maybe a
Just (Vector a -> Vector b -> Vector (a, b)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip Vector a
as Vector b
bs)
    | Bool
otherwise                            = Maybe (Vector (a, b))
forall a. Maybe a
Nothing

  zipMatchWith :: forall a b c.
(a -> b -> Maybe c) -> Vector a -> Vector b -> Maybe (Vector c)
zipMatchWith a -> b -> Maybe c
u Vector a
as Vector b
bs
    | Vector a -> Int
forall a. Vector a -> Int
Vector.length Vector a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector b -> Int
forall a. Vector a -> Int
Vector.length Vector b
bs = (a -> b -> Maybe c) -> Vector a -> Vector b -> Maybe (Vector c)
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> Vector a -> Vector b -> m (Vector c)
Vector.zipWithM a -> b -> Maybe c
u Vector a
as Vector b
bs
    | Bool
otherwise                            = Maybe (Vector c)
forall a. Maybe a
Nothing

instance (Eq k, Hashable k) => Matchable (HashMap k) where
  zipMatch :: forall a b. HashMap k a -> HashMap k b -> Maybe (HashMap k (a, b))
zipMatch HashMap k a
as HashMap k b
bs
    | HashMap k a -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap k a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap k b -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap k b
bs =
        (k -> a -> Maybe (a, b)) -> HashMap k a -> Maybe (HashMap k (a, b))
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey (\k
k a
a -> (,) a
a (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> HashMap k b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
k HashMap k b
bs) HashMap k a
as
    | Bool
otherwise = Maybe (HashMap k (a, b))
forall a. Maybe a
Nothing
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> HashMap k a -> HashMap k b -> Maybe (HashMap k c)
zipMatchWith a -> b -> Maybe c
u HashMap k a
as HashMap k b
bs
    | HashMap k a -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap k a
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap k b -> Int
forall k v. HashMap k v -> Int
HashMap.size HashMap k b
bs =
        (k -> a -> Maybe c) -> HashMap k a -> Maybe (HashMap k c)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey (\k
k a
a -> a -> b -> Maybe c
u a
a (b -> Maybe c) -> Maybe b -> Maybe c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< k -> HashMap k b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
k HashMap k b
bs) HashMap k a
as
    | Bool
otherwise = Maybe (HashMap k c)
forall a. Maybe a
Nothing

instance (Generic1 f, Matchable' (Rep1 f)) => Matchable (Generically1 f) where
  zipMatchWith :: forall a b c.
(a -> b -> Maybe c)
-> Generically1 f a -> Generically1 f b -> Maybe (Generically1 f c)
zipMatchWith a -> b -> Maybe c
f (Generically1 f a
x) (Generically1 f b
y) = f c -> Generically1 f c
forall {k} (f :: k -> *) (a :: k). f a -> Generically1 f a
Generically1 (f c -> Generically1 f c)
-> Maybe (f c) -> Maybe (Generically1 f c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith a -> b -> Maybe c
f f a
x f b
y

{- * Generic definition

An instance of Matchable can be implemened through GHC Generics.
As a prerequisite, you need to make your type an instance of 'Functor' and 'Generic1'.
Both of them can be derived using DeriveFunctor and DeriveGeneric extension.

Using 'Generically1' and DerivingVia extension, @Matchable@ instance can be automatically derived.

>>> :set -XDeriveFunctor
>>> :set -XDeriveGeneric
>>> :set -XDerivingVia
>>> :{
  data MyTree label a = Leaf a | Node label [MyTree label a]
    deriving stock (Show, Read, Eq, Ord, Functor, Generic1)
    deriving (Eq1, Matchable) via (Generically1 (MyTree label))
:}

Alternatively, you can use 'genericZipMatchWith' to manually define @zipMatchWith@ method.

> 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 (Functor t, Eq1 t) => 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 :: forall (t :: * -> *) a b c.
(Generic1 t, Matchable' (Rep1 t)) =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
genericZipMatchWith a -> b -> Maybe c
u t a
ta t b
tb = Rep1 t c -> t c
forall a. Rep1 t a -> t a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 t c -> t c) -> Maybe (Rep1 t c) -> Maybe (t c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> Rep1 t a -> Rep1 t b -> Maybe (Rep1 t c)
forall a b c.
(a -> b -> Maybe c) -> Rep1 t a -> Rep1 t b -> Maybe (Rep1 t c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u (t a -> Rep1 t a
forall a. t a -> Rep1 t a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t a
ta) (t b -> Rep1 t b
forall a. t a -> Rep1 t a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t b
tb)
{-# INLINABLE genericZipMatchWith #-}

instance Matchable' V1 where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c. (a -> b -> Maybe c) -> V1 a -> V1 b -> Maybe (V1 c)
zipMatchWith' a -> b -> Maybe c
_ V1 a
a V1 b
_ = case V1 a
a of { }

instance Matchable' U1 where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c. (a -> b -> Maybe c) -> U1 a -> U1 b -> Maybe (U1 c)
zipMatchWith' a -> b -> Maybe c
_ U1 a
_ U1 b
_ = U1 c -> Maybe (U1 c)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 c
forall k (p :: k). U1 p
U1

instance Matchable' Par1 where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c) -> Par1 a -> Par1 b -> Maybe (Par1 c)
zipMatchWith' a -> b -> Maybe c
u (Par1 a
a) (Par1 b
b) = c -> Par1 c
forall p. p -> Par1 p
Par1 (c -> Par1 c) -> Maybe c -> Maybe (Par1 c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> b -> Maybe c
u a
a b
b

instance Matchable f => Matchable' (Rec1 f) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c) -> Rec1 f a -> Rec1 f b -> Maybe (Rec1 f c)
zipMatchWith' a -> b -> Maybe c
u (Rec1 f a
fa) (Rec1 f b
fb) = f c -> Rec1 f c
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f c -> Rec1 f c) -> Maybe (f c) -> Maybe (Rec1 f c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall a b c. (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith a -> b -> Maybe c
u f a
fa f b
fb

instance (Eq c) => Matchable' (K1 i c) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c) -> K1 i c a -> K1 i c b -> Maybe (K1 i c c)
zipMatchWith' a -> b -> Maybe c
_ (K1 c
ca) (K1 c
cb)
    = if c
ca c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
cb then K1 i c c -> Maybe (K1 i c c)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> K1 i c c
forall k i c (p :: k). c -> K1 i c p
K1 c
ca) else Maybe (K1 i c c)
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty

instance Matchable' f => Matchable' (M1 i c f) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c)
-> M1 i c f a -> M1 i c f b -> Maybe (M1 i c f c)
zipMatchWith' a -> b -> Maybe c
u (M1 f a
fa) (M1 f b
fb) = f c -> M1 i c f c
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f c -> M1 i c f c) -> Maybe (f c) -> Maybe (M1 i c f c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall a b c. (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u f a
fa f b
fb

instance (Matchable' f, Matchable' g) => Matchable' (f :+: g) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c)
-> (:+:) f g a -> (:+:) f g b -> Maybe ((:+:) f g c)
zipMatchWith' a -> b -> Maybe c
u (L1 f a
fa) (L1 f b
fb) = f c -> (:+:) f g c
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f c -> (:+:) f g c) -> Maybe (f c) -> Maybe ((:+:) f g c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall a b c. (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u f a
fa f b
fb
  zipMatchWith' a -> b -> Maybe c
u (R1 g a
ga) (R1 g b
gb) = g c -> (:+:) f g c
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g c -> (:+:) f g c) -> Maybe (g c) -> Maybe ((:+:) f g c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall a b c. (a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u g a
ga g b
gb
  zipMatchWith' a -> b -> Maybe c
_ (:+:) f g a
_       (:+:) f g b
_       = Maybe ((:+:) f g c)
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty

instance (Matchable' f, Matchable' g) => Matchable' (f :*: g) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c)
-> (:*:) f g a -> (:*:) f g b -> Maybe ((:*:) f g c)
zipMatchWith' a -> b -> Maybe c
u (f a
fa :*: g a
ga) (f b
fb :*: g b
gb) =
    (f c -> g c -> (:*:) f g c)
-> Maybe (f c) -> Maybe (g c) -> Maybe ((:*:) f g c)
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f c -> g c -> (:*:) f g c
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) ((a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall a b c. (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u f a
fa f b
fb) ((a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall a b c. (a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u g a
ga g b
gb)

instance (Matchable f, Matchable' g) => Matchable' (f :.: g) where
  {-# INLINABLE zipMatchWith' #-}
  zipMatchWith' :: forall a b c.
(a -> b -> Maybe c)
-> (:.:) f g a -> (:.:) f g b -> Maybe ((:.:) f g c)
zipMatchWith' a -> b -> Maybe c
u (Comp1 f (g a)
fga) (Comp1 f (g b)
fgb) =
    f (g c) -> (:.:) f g c
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g c) -> (:.:) f g c) -> Maybe (f (g c)) -> Maybe ((:.:) f g c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g a -> g b -> Maybe (g c))
-> f (g a) -> f (g b) -> Maybe (f (g c))
forall a b c. (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)
forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith ((a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall a b c. (a -> b -> Maybe c) -> g a -> g b -> Maybe (g c)
forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u) f (g a)
fga f (g b)
fgb

-- Utility functions

unsafeFillIn :: (Traversable f) => (a -> b -> Maybe c) -> f a -> [b] -> Maybe (f c)
unsafeFillIn :: forall (f :: * -> *) a b c.
Traversable f =>
(a -> b -> Maybe c) -> f a -> [b] -> Maybe (f c)
unsafeFillIn a -> b -> Maybe c
u f a
as [b]
bs = (f c, [b]) -> f c
forall a b. (a, b) -> a
fst ((f c, [b]) -> f c) -> Maybe (f c, [b]) -> Maybe (f c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FillIn b (f c) -> [b] -> Maybe (f c, [b])
forall b a. FillIn b a -> [b] -> Maybe (a, [b])
runFillIn ((a -> FillIn b c) -> f a -> FillIn b (f c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse ((a -> b -> Maybe c) -> a -> FillIn b c
forall a b c. (a -> b -> Maybe c) -> a -> FillIn b c
useOne a -> b -> Maybe c
u) f a
as) [b]
bs

-- Just a @StateT [b] Maybe@ but avoids to depend on transformers
newtype FillIn b a = FillIn { forall b a. FillIn b a -> [b] -> Maybe (a, [b])
runFillIn :: [b] -> Maybe (a, [b]) }
  deriving ((forall a b. (a -> b) -> FillIn b a -> FillIn b b)
-> (forall a b. a -> FillIn b b -> FillIn b a)
-> Functor (FillIn b)
forall a b. a -> FillIn b b -> FillIn b a
forall a b. (a -> b) -> FillIn b a -> FillIn b b
forall b a b. a -> FillIn b b -> FillIn b a
forall b a b. (a -> b) -> FillIn b a -> FillIn b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall b a b. (a -> b) -> FillIn b a -> FillIn b b
fmap :: forall a b. (a -> b) -> FillIn b a -> FillIn b b
$c<$ :: forall b a b. a -> FillIn b b -> FillIn b a
<$ :: forall a b. a -> FillIn b b -> FillIn b a
Functor)

instance Applicative (FillIn b) where
  pure :: forall a. a -> FillIn b a
pure a
a = ([b] -> Maybe (a, [b])) -> FillIn b a
forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn (([b] -> Maybe (a, [b])) -> FillIn b a)
-> ([b] -> Maybe (a, [b])) -> FillIn b a
forall a b. (a -> b) -> a -> b
$ \[b]
bs -> (a, [b]) -> Maybe (a, [b])
forall a. a -> Maybe a
Just (a
a, [b]
bs)
  FillIn [b] -> Maybe (a -> b, [b])
fx <*> :: forall a b. FillIn b (a -> b) -> FillIn b a -> FillIn b b
<*> FillIn [b] -> Maybe (a, [b])
fy = ([b] -> Maybe (b, [b])) -> FillIn b b
forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn (([b] -> Maybe (b, [b])) -> FillIn b b)
-> ([b] -> Maybe (b, [b])) -> FillIn b b
forall a b. (a -> b) -> a -> b
$ \[b]
bs ->
    [b] -> Maybe (a -> b, [b])
fx [b]
bs Maybe (a -> b, [b])
-> ((a -> b, [b]) -> Maybe (b, [b])) -> Maybe (b, [b])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a -> b
x, [b]
bs') ->
    [b] -> Maybe (a, [b])
fy [b]
bs' Maybe (a, [b]) -> ((a, [b]) -> Maybe (b, [b])) -> Maybe (b, [b])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
y, [b]
bs'') -> (b, [b]) -> Maybe (b, [b])
forall a. a -> Maybe a
Just (a -> b
x a
y, [b]
bs'')

useOne :: (a -> b -> Maybe c) -> a -> FillIn b c
useOne :: forall a b c. (a -> b -> Maybe c) -> a -> FillIn b c
useOne a -> b -> Maybe c
u a
a = ([b] -> Maybe (c, [b])) -> FillIn b c
forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn (([b] -> Maybe (c, [b])) -> FillIn b c)
-> ([b] -> Maybe (c, [b])) -> FillIn b c
forall a b. (a -> b) -> a -> b
$ \[b]
bs -> case [b]
bs of
  [] -> Maybe (c, [b])
forall a. Maybe a
Nothing
  (b
b:[b]
bs') -> a -> b -> Maybe c
u a
a b
b Maybe c -> (c -> Maybe (c, [b])) -> Maybe (c, [b])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c
c -> (c, [b]) -> Maybe (c, [b])
forall a. a -> Maybe a
Just (c
c, [b]
bs')