{-# LANGUAGE UndecidableInstances #-}

-- | A set of functions for matching on Nix expression trees and extracting the
-- values of sub-trees.
module Nix.Match
  ( match,
    findMatches,
    Matchable (..),
    GMatchable (..),
    WithHoles (..),
    addHoles,
    addHolesLoc,
    isOptionalPath,
  )
where

import Control.Category ((>>>))
import Control.Monad (void)
import Data.Data
import Data.Fix
import Data.Foldable
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Monoid hiding (All)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Base (NonEmpty ((:|)))
import GHC.Generics
import Nix

-- | Like 'Fix' but each layer could instead be a 'Hole'
data WithHoles t v
  = Hole !v
  | Term !(t (WithHoles t v))

deriving instance (Typeable t, Data (t (WithHoles t v)), Data v) => Data (WithHoles t v)

-- | Match a tree with holes against a tree without holes, returning the values
-- of the holes if it matches.
--
-- 'NExprF' and 'NExprLocF' are both instances of 'Matchable'. 'NExprLocF' does
-- not require the annotations to match. Please see the 'Matchable' instance
-- documentation for 'NExprF' for more details.
--
-- >>> import Nix.TH
-- >>> match (addHoles [nix|{foo = x: ^foo; bar = ^bar;}|]) [nix|{foo = x: "hello"; bar = "world"; baz = "!";}|]
-- Just [("bar",Fix (NStr (DoubleQuoted [Plain "world"]))),("foo",Fix (NStr (DoubleQuoted [Plain "hello"])))]
match :: Matchable t => WithHoles t v -> Fix t -> Maybe [(v, Fix t)]
match :: forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> Maybe [(v, Fix t)]
match = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Endo a -> a -> a
`appEndo` []) forall b c a1 a2. (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
.: forall {a}. WithHoles t a -> Fix t -> Maybe (Endo [(a, Fix t)])
go
  where
    go :: WithHoles t a -> Fix t -> Maybe (Endo [(a, Fix t)])
go = \case
      Hole a
v -> \Fix t
t -> forall a. a -> Maybe a
Just (forall a. (a -> a) -> Endo a
Endo ((a
v, Fix t
t) forall a. a -> [a] -> [a]
:))
      Term t (WithHoles t a)
s -> \(Fix t (Fix t)
t) -> do
        t (WithHoles t a, Fix t)
m <- forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft t (WithHoles t a)
s t (Fix t)
t
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry WithHoles t a -> Fix t -> Maybe (Endo [(a, Fix t)])
go) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ t (WithHoles t a, Fix t)
m

-- | Find all the needles in a haystack, returning the matched expression as
-- well as their filled holes. Results are returned productively in preorder.
--
-- >>> import Nix.TH
-- >>> import Control.Arrow
-- >>> pretty = prettyNix *** (fmap @[] (fmap @((,) Text) prettyNix))
-- >>> pretty <$> findMatches (addHoles [nix|{x=^x;}|]) [nix|{x=1;a={x=2;};}|]
-- [({ x = 1; a = { x = 2; }; },[("x",1)]),({ x = 2; },[("x",2)])]
findMatches ::
  Matchable t =>
  -- | Needle
  WithHoles t v ->
  -- | Haystack
  Fix t ->
  [(Fix t, [(v, Fix t)])]
findMatches :: forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> [(Fix t, [(v, Fix t)])]
findMatches WithHoles t v
needle Fix t
haystack =
  [(Fix t
s, [(v, Fix t)]
r) | Fix t
s <- forall (f :: * -> *). Foldable f => Fix f -> [Fix f]
fixUniverse Fix t
haystack, Just [(v, Fix t)]
r <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> Maybe [(v, Fix t)]
match WithHoles t v
needle Fix t
s]

-- | Get every @f@ in a @Fix f@ in preorder.
fixUniverse :: Foldable f => Fix f -> [Fix f]
fixUniverse :: forall (f :: * -> *). Foldable f => Fix f -> [Fix f]
fixUniverse Fix f
e = Fix f
e forall a. a -> [a] -> [a]
: (forall (f :: * -> *). Foldable f => Fix f -> [Fix f]
fixUniverse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall (f :: * -> *). Fix f -> f (Fix f)
unFix Fix f
e))

-- | Make syntactic holes into 'Hole's
addHoles :: NExpr -> WithHoles NExprF VarName
addHoles :: NExpr -> WithHoles NExprF VarName
addHoles =
  forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    NSynHole VarName
n -> forall (t :: * -> *) v. v -> WithHoles t v
Hole VarName
n
    NExprF NExpr
e -> forall (t :: * -> *) v. t (WithHoles t v) -> WithHoles t v
Term forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NExpr -> WithHoles NExprF VarName
addHoles forall a b. (a -> b) -> a -> b
$ NExprF NExpr
e

-- | Make syntactic holes into 'Hole's
addHolesLoc :: NExprLoc -> WithHoles NExprLocF VarName
addHolesLoc :: NExprLoc -> WithHoles (Compose (AnnUnit SrcSpan) NExprF) VarName
addHolesLoc =
  forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    Compose (AnnUnit SrcSpan
_ (NSynHole VarName
n)) -> forall (t :: * -> *) v. v -> WithHoles t v
Hole VarName
n
    Compose (AnnUnit SrcSpan) NExprF NExprLoc
e -> forall (t :: * -> *) v. t (WithHoles t v) -> WithHoles t v
Term forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NExprLoc -> WithHoles (Compose (AnnUnit SrcSpan) NExprF) VarName
addHolesLoc forall a b. (a -> b) -> a -> b
$ Compose (AnnUnit SrcSpan) NExprF NExprLoc
e

----------------------------------------------------------------
-- Matchable
----------------------------------------------------------------

-- | Instances for this class can be derived for any type with a 'Generic1'
-- instance.
class Traversable t => Matchable t where
  -- | Match one level of structure, returning the matched structure with sub
  -- structures to match. Needle is the first argument, matchee is the second.
  --
  -- Unlike the @Unifiable@ class in the "unification-fd" package, this doesn't
  -- have to be a commutative operation, the needle will always be the first
  -- parameter and instances are free to treat if differently if appropriate.
  zipMatchLeft :: t a -> t b -> Maybe (t (a, b))
  default zipMatchLeft ::
    (Generic1 t, GMatchable (Rep1 t)) =>
    t a ->
    t b ->
    Maybe (t (a, b))
  zipMatchLeft t a
l t b
r = 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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t a
l) (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 t b
r)

-- | Match a composition of 'Matchable' things
zipMatchLeft2 ::
  (Matchable f, Matchable t) => t (f a) -> t (f b) -> Maybe (t (f (a, b)))
zipMatchLeft2 :: forall (f :: * -> *) (t :: * -> *) a b.
(Matchable f, Matchable t) =>
t (f a) -> t (f b) -> Maybe (t (f (a, b)))
zipMatchLeft2 t (f a)
a t (f b)
b = forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft t (f a)
a t (f b)
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft)

----------------------------------------------------------------
-- Matchable instance for NExprF and NExprLocF
----------------------------------------------------------------

-- | There are a few special cases when matching expressions to make writing
-- matchers nicer:
--
-- - For attrsets and let bindings, the matching is done on the needle's keys
--   only. i.e. the matchee may have extra keys which are ignored.
--
-- - For attrsets and let bindings, bindings which have a LHS beginning with
--   @_@ are treated as optional. If they are not present then any holes on
--   their RHS will not be filled.
--
-- - Attrsets match ignoring recursiveness
--
-- - If a function in the needle has @_@ as its parameter, it matches
--   everything, so @_@ acts as a wildcard pattern.
instance Matchable NExprF where
  zipMatchLeft :: forall a b. NExprF a -> NExprF b -> Maybe (NExprF (a, b))
zipMatchLeft (NSet Recursivity
_ [Binding a]
bs1) (NSet Recursivity
_ [Binding b]
bs2) = do
    ([Binding a]
bs1', [Binding b]
bs2') <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q r.
[Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)]
reduceBindings [Binding a]
bs1 [Binding b]
bs2
    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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft
        (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (forall r. Recursivity -> [Binding r] -> NExprF r
NSet Recursivity
NonRecursive [Binding a]
bs1'))
        (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (forall r. Recursivity -> [Binding r] -> NExprF r
NSet Recursivity
NonRecursive [Binding b]
bs2'))
  zipMatchLeft (NLet [Binding a]
bs1 a
e1) (NLet [Binding b]
bs2 b
e2) = do
    ([Binding a]
bs1', [Binding b]
bs2') <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q r.
[Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)]
reduceBindings [Binding a]
bs1 [Binding b]
bs2
    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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (forall r. [Binding r] -> r -> NExprF r
NLet [Binding a]
bs1' a
e1)) (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (forall r. [Binding r] -> r -> NExprF r
NLet [Binding b]
bs2' b
e2))
  zipMatchLeft (NAbs (Param VarName
"_") a
e1) (NAbs Params b
_ b
e2) = do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Params r -> r -> NExprF r
NAbs (forall r. VarName -> Params r
Param VarName
"_") (a
e1, b
e2)
  zipMatchLeft NExprF a
l NExprF b
r = 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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 NExprF a
l) (forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 NExprF b
r)

-- | Bindings are compared on top level structure only.
--
-- Doesn't filter bindings in the needle, as they must all be present
--
-- Bindings are returned according to their order in the needle.
--
-- Any optional (name begins with @_@) bindings may be removed from the needle.
--
-- Left hand sides are matched purely on the top level structure, this means
-- that "${a}" and "${b}" appear the same to this function, and it may not
-- match them up correctly.
reduceBindings :: [Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)]
reduceBindings :: forall q r.
[Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)]
reduceBindings [Binding q]
needle [Binding r]
matchee =
  let -- A binding is optional if the lhs starts with a '_', return the same
      -- binding but without the '_'
      isOptional :: Binding r -> Maybe (Binding r)
isOptional = \case
        NamedVar NAttrPath r
p r
e SourcePos
l | Just NAttrPath r
p' <- forall r. NAttrPath r -> Maybe (NAttrPath r)
isOptionalPath NAttrPath r
p -> forall a. a -> Maybe a
Just (forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar NAttrPath r
p' r
e SourcePos
l)
        Binding r
_ -> forall a. Maybe a
Nothing

      -- Get a representation of the left hand side which has an Eq instance
      -- This will represent some things the samelike "${a}" and "${b}"
      getLHS :: Binding a -> Either (NonEmpty (NKeyName ())) (Maybe (), [VarName])
getLHS = \case
        NamedVar NAttrPath a
p a
_ SourcePos
_ -> forall a b. a -> Either a b
Left (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void NAttrPath a
p)
        Inherit Maybe a
r [VarName]
ps SourcePos
_ -> forall a b. b -> Either a b
Right (forall (f :: * -> *) a. Functor f => f a -> f ()
void Maybe a
r, [VarName]
ps)
   in forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ (Binding q
n',) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Binding r)
m
          | -- For each binding in the needle
            Binding q
n <- [Binding q]
needle,
            let opt :: Maybe (Binding q)
opt = forall {r}. Binding r -> Maybe (Binding r)
isOptional Binding q
n
                -- \| Use the optional demangled version if present
                n' :: Binding q
n' = forall a. a -> Maybe a -> a
fromMaybe Binding q
n Maybe (Binding q)
opt
                lhs :: Either (NonEmpty (NKeyName ())) (Maybe (), [VarName])
lhs = forall {a}.
Binding a -> Either (NonEmpty (NKeyName ())) (Maybe (), [VarName])
getLHS Binding q
n'
                -- Find the first matching binding in the matchee
                m :: Maybe (Binding r)
m = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Either (NonEmpty (NKeyName ())) (Maybe (), [VarName])
lhs forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
Binding a -> Either (NonEmpty (NKeyName ())) (Maybe (), [VarName])
getLHS) [Binding r]
matchee,
            -- Skip this element if it is not present in the matchee and is optional in the needle
            forall a. Maybe a -> Bool
isNothing Maybe (Binding q)
opt Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (Binding r)
m
        ]

-- | Basically: does the path begin with an underscore, if so return it removed
-- without the underscore.
isOptionalPath :: NAttrPath r -> Maybe (NAttrPath r)
isOptionalPath :: forall r. NAttrPath r -> Maybe (NAttrPath r)
isOptionalPath = \case
  StaticKey (VarName Text
n) :| [] | Just (Char
'_', Text
t) <- Text -> Maybe (Char, Text)
T.uncons Text
n -> forall a. a -> Maybe a
Just (forall r. VarName -> NKeyName r
StaticKey (Text -> VarName
VarName Text
t) forall a. a -> [a] -> NonEmpty a
:| [])
  DynamicKey (Plain (DoubleQuoted [Plain Text
n])) :| [NKeyName r]
rs
    | Just (Char
'_', Text
t) <- Text -> Maybe (Char, Text)
T.uncons Text
n ->
        forall a. a -> Maybe a
Just
          (forall r. Antiquoted (NString r) r -> NKeyName r
DynamicKey (forall v r. v -> Antiquoted v r
Plain (forall r. [Antiquoted Text r] -> NString r
DoubleQuoted [forall v r. v -> Antiquoted v r
Plain Text
t])) forall a. a -> [a] -> NonEmpty a
:| [NKeyName r]
rs)
  NAttrPath r
_ -> forall a. Maybe a
Nothing

--
-- hnix types
--

instance Matchable NString

instance Matchable (Antiquoted Text)

-- | The matched pair uses the source location of the first argument
instance Matchable Binding where
  zipMatchLeft :: forall a b. Binding a -> Binding b -> Maybe (Binding (a, b))
zipMatchLeft (NamedVar NAttrPath a
p1 a
v1 SourcePos
_) (NamedVar NAttrPath b
p2 b
v2 SourcePos
l) = do
    NonEmpty (NKeyName (a, b))
p <- forall (f :: * -> *) (t :: * -> *) a b.
(Matchable f, Matchable t) =>
t (f a) -> t (f b) -> Maybe (t (f (a, b)))
zipMatchLeft2 NAttrPath a
p1 NAttrPath b
p2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar NonEmpty (NKeyName (a, b))
p (a
v1, b
v2) SourcePos
l)
  zipMatchLeft (Inherit Maybe a
x1 [VarName]
ys1 SourcePos
l) (Inherit Maybe b
x2 [VarName]
ys2 SourcePos
_)
    | [VarName]
ys1 forall a. Eq a => a -> a -> Bool
== [VarName]
ys2 = do
        Maybe (a, b)
x <- forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft Maybe a
x1 Maybe b
x2
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall r. Maybe r -> [VarName] -> SourcePos -> Binding r
Inherit Maybe (a, b)
x [VarName]
ys1 SourcePos
l)
  zipMatchLeft Binding a
_ Binding b
_ = forall a. Maybe a
Nothing

-- | No Generic1 instance
instance Matchable NKeyName where
  zipMatchLeft :: forall a b. NKeyName a -> NKeyName b -> Maybe (NKeyName (a, b))
zipMatchLeft (StaticKey VarName
k1) (StaticKey VarName
k2) | VarName
k1 forall a. Eq a => a -> a -> Bool
== VarName
k2 = forall a. a -> Maybe a
Just (forall r. VarName -> NKeyName r
StaticKey VarName
k1)
  zipMatchLeft (DynamicKey Antiquoted (NString a) a
EscapedNewline) (DynamicKey Antiquoted (NString b) b
EscapedNewline) =
    forall a. a -> Maybe a
Just (forall r. Antiquoted (NString r) r -> NKeyName r
DynamicKey forall v r. Antiquoted v r
EscapedNewline)
  zipMatchLeft (DynamicKey (Plain NString a
k1)) (DynamicKey (Plain NString b
k2)) = do
    NString (a, b)
k <- forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft NString a
k1 NString b
k2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Antiquoted (NString r) r -> NKeyName r
DynamicKey (forall v r. v -> Antiquoted v r
Plain NString (a, b)
k)
  zipMatchLeft (DynamicKey (Antiquoted a
k1)) (DynamicKey (Antiquoted b
k2)) =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Antiquoted (NString r) r -> NKeyName r
DynamicKey (forall v r. r -> Antiquoted v r
Antiquoted (a
k1, b
k2))
  zipMatchLeft NKeyName a
_ NKeyName b
_ = forall a. Maybe a
Nothing

instance Matchable Params

-- | Doesn't require the annotations to match, returns the second annotation.
instance Matchable (AnnUnit ann) where
  zipMatchLeft :: forall a b.
AnnUnit ann a -> AnnUnit ann b -> Maybe (AnnUnit ann (a, b))
zipMatchLeft (AnnUnit ann
_ a
a1) (AnnUnit ann
ann2 b
a2) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall ann expr. ann -> expr -> AnnUnit ann expr
AnnUnit ann
ann2 (a
a1, b
a2)

--
-- base types
--

instance Matchable []

instance Matchable NonEmpty

instance Matchable Maybe

instance Eq a => Matchable ((,) a)

instance (Matchable f, Matchable g) => Matchable (Compose f g)

----------------------------------------------------------------
-- Generic Instance for Matchable
----------------------------------------------------------------

-- | A class used in the @default@ definition for 'zipMatchLeft'
class (Traversable t, Generic1 t) => GMatchable t where
  gZipMatchLeft :: t a -> t b -> Maybe (t (a, b))

instance GMatchable t => GMatchable (M1 m i t) where
  gZipMatchLeft :: forall a b. M1 m i t a -> M1 m i t b -> Maybe (M1 m i t (a, b))
gZipMatchLeft (M1 t a
l) (M1 t b
r) = 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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft t a
l t b
r

instance GMatchable U1 where
  gZipMatchLeft :: forall a b. U1 a -> U1 b -> Maybe (U1 (a, b))
gZipMatchLeft U1 a
_ U1 b
_ = forall a. a -> Maybe a
Just forall k (p :: k). U1 p
U1

instance Eq c => GMatchable (K1 m c) where
  gZipMatchLeft :: forall a b. K1 m c a -> K1 m c b -> Maybe (K1 m c (a, b))
gZipMatchLeft (K1 c
l) (K1 c
r)
    | c
l forall a. Eq a => a -> a -> Bool
== c
r = forall a. a -> Maybe a
Just (forall k i c (p :: k). c -> K1 i c p
K1 c
l)
    | Bool
otherwise = forall a. Maybe a
Nothing

instance GMatchable Par1 where
  gZipMatchLeft :: forall a b. Par1 a -> Par1 b -> Maybe (Par1 (a, b))
gZipMatchLeft (Par1 a
l) (Par1 b
r) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. p -> Par1 p
Par1 forall a b. (a -> b) -> a -> b
$ (a
l, b
r)

instance Matchable x => GMatchable (Rec1 x) where
  gZipMatchLeft :: forall a b. Rec1 x a -> Rec1 x b -> Maybe (Rec1 x (a, b))
gZipMatchLeft (Rec1 x a
l) (Rec1 x b
r) = 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.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft x a
l x b
r

instance (GMatchable l, GMatchable r) => GMatchable (l :+: r) where
  gZipMatchLeft :: forall a b. (:+:) l r a -> (:+:) l r b -> Maybe ((:+:) l r (a, b))
gZipMatchLeft (L1 l a
l) (L1 l b
r) = 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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft l a
l l b
r
  gZipMatchLeft (R1 r a
l) (R1 r b
r) = 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.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft r a
l r b
r
  gZipMatchLeft (:+:) l r a
_ (:+:) l r b
_ = forall a. Maybe a
Nothing

instance (GMatchable l, GMatchable r) => GMatchable (l :*: r) where
  gZipMatchLeft :: forall a b. (:*:) l r a -> (:*:) l r b -> Maybe ((:*:) l r (a, b))
gZipMatchLeft (l a
l1 :*: r a
l2) (l b
r1 :*: r b
r2) =
    forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft l a
l1 l b
r1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) a b.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft r a
l2 r b
r2

instance (Matchable a, GMatchable b) => GMatchable (a :.: b) where
  gZipMatchLeft :: forall a b. (:.:) a b a -> (:.:) a b b -> Maybe ((:.:) a b (a, b))
gZipMatchLeft (Comp1 a (b a)
l) (Comp1 a (b b)
r) = do
    a (b (a, b))
x <- forall (t :: * -> *) a b.
Matchable t =>
t a -> t b -> Maybe (t (a, b))
zipMatchLeft a (b a)
l a (b b)
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (t :: * -> *) a b.
GMatchable t =>
t a -> t b -> Maybe (t (a, b))
gZipMatchLeft)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 a (b (a, b))
x)

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

(.:) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
.: :: forall b c a1 a2. (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.:) = forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)