{-# 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.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

-- $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 = forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (forall a b c. ((a, b) -> c) -> a -> b -> c
curry 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 = forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith 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 =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Law-violating Matchable instance") forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (\a
a a
_ -> 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 = forall (t :: * -> *) a b.
Matchable t =>
(a -> b -> Bool) -> t a -> t b -> Bool
liftEqDefault 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 forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing
  in forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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 = 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 = 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 = 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
_ = forall a. a -> Maybe a
Just 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 = 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 = 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 = 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 = 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 = 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 = 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
    | forall a. Seq a -> Int
Seq.length Seq a
as forall a. Eq a => a -> a -> Bool
== forall a. Seq a -> Int
Seq.length Seq b
bs = forall a. a -> Maybe a
Just (forall a b. Seq a -> Seq b -> Seq (a, b)
Seq.zip Seq a
as Seq b
bs)
    | Bool
otherwise                      = 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
    | forall a. Seq a -> Int
Seq.length Seq a
as forall a. Eq a => a -> a -> Bool
== forall a. Seq a -> Int
Seq.length Seq b
bs = 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 (forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Seq b
bs)
    | Bool
otherwise                      = 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
    | forall k a. Map k a -> Int
Map.size Map k a
as forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> Int
Map.size Map k b
bs =
        forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith a -> b -> Maybe c
u) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map k a
as) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map k b
bs)
    | Bool
otherwise                  = 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
    | forall a. IntMap a -> Int
IntMap.size IntMap a
as forall a. Eq a => a -> a -> Bool
== 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 = forall a. Maybe a
Nothing
    where
      miss :: WhenMissing Maybe x y
miss = forall (f :: * -> *) x y.
Applicative f =>
(Int -> x -> f y) -> WhenMissing f x y
IntMap.traverseMissing (\Int
_ x
_ -> forall a. Maybe a
Nothing)
      merger :: IntMap a -> IntMap b -> Maybe (IntMap c)
merger = 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 forall {x} {y}. WhenMissing Maybe x y
miss forall {x} {y}. WhenMissing Maybe x y
miss (forall (f :: * -> *) x y z.
Applicative f =>
(Int -> x -> y -> f z) -> WhenMatched f x y z
IntMap.zipWithAMatched (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 = 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
    | forall a. Vector a -> Int
Vector.length Vector a
as forall a. Eq a => a -> a -> Bool
== forall a. Vector a -> Int
Vector.length Vector b
bs = forall a. a -> Maybe a
Just (forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip Vector a
as Vector b
bs)
    | Bool
otherwise                            = 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
    | forall a. Vector a -> Int
Vector.length Vector a
as forall a. Eq a => a -> a -> Bool
== forall a. Vector a -> Int
Vector.length Vector b
bs = 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                            = 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
    | forall k v. HashMap k v -> Int
HashMap.size HashMap k a
as forall a. Eq a => a -> a -> Bool
== forall k v. HashMap k v -> Int
HashMap.size HashMap k b
bs =
        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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 = 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
    | forall k v. HashMap k v -> Int
HashMap.size HashMap k a
as forall a. Eq a => a -> a -> Bool
== forall k v. HashMap k v -> Int
HashMap.size HashMap k b
bs =
        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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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 = forall a. Maybe a
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 :: 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 = forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b c.
Matchable' t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith' a -> b -> Maybe c
u (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t a
ta) (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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) = forall p. p -> Par1 p
Par1 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) = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Eq a => a -> a -> Bool
== c
cb then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k i c (p :: k). c -> K1 i c p
K1 c
ca) else 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) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_       = 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) =
    forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (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) (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) =
    forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b c.
Matchable t =>
(a -> b -> Maybe c) -> t a -> t b -> Maybe (t c)
zipMatchWith (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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. FillIn b a -> [b] -> Maybe (a, [b])
runFillIn (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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 -> 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
<$ :: forall a b. a -> FillIn b b -> FillIn b a
$c<$ :: forall b a b. a -> FillIn b b -> FillIn b a
fmap :: forall a b. (a -> b) -> FillIn b a -> FillIn b b
$cfmap :: forall b a b. (a -> b) -> FillIn b a -> FillIn b b
Functor)

instance Applicative (FillIn b) where
  pure :: forall a. a -> FillIn b a
pure a
a = forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn forall a b. (a -> b) -> a -> b
$ \[b]
bs -> 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 = forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn forall a b. (a -> b) -> a -> b
$ \[b]
bs ->
    [b] -> Maybe (a -> b, [b])
fx [b]
bs 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' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
y, [b]
bs'') -> 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 = forall b a. ([b] -> Maybe (a, [b])) -> FillIn b a
FillIn forall a b. (a -> b) -> a -> b
$ \[b]
bs -> case [b]
bs of
  [] -> forall a. Maybe a
Nothing
  (b
b:[b]
bs') -> a -> b -> Maybe c
u a
a b
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c
c -> forall a. a -> Maybe a
Just (c
c, [b]
bs')