ZipMatch.hs

{-# LANGUAGE FlexibleContexts #-}

-- | A class to match term structures
module Hyper.Class.ZipMatch
    ( ZipMatch (..)
    , zipMatch2
    , zipMatchA
    , zipMatch_
    , zipMatch1_
    ) where

import GHC.Generics
import GHC.Generics.Lens (generic1)
import Hyper.Class.Foldable (HFoldable, htraverse1_, htraverse_)
import Hyper.Class.Functor (HFunctor (..))
import Hyper.Class.Nodes (HNodes (..), HWitness)
import Hyper.Class.Traversable (HTraversable, htraverse)
import Hyper.Type (type (#))
import Hyper.Type.Pure (Pure (..), _Pure)

import Hyper.Internal.Prelude

-- | A class to match term structures.
--
-- Similar to a partial version of 'Hyper.Class.Apply.Apply' but the semantics are different -
-- when the terms contain plain values, 'Hyper.Class.Apply.hzip' would append them,
-- but 'zipMatch' would compare them and only produce a result if they match.
--
-- The @TemplateHaskell@ generators 'Hyper.TH.Apply.makeHApply' and 'Hyper.TH.ZipMatch.makeZipMatch'
-- create the instances according to these semantics.
class ZipMatch h where
    -- | Compare two structures
    --
    -- >>> zipMatch (NewPerson p0) (NewPerson p1)
    -- Just (NewPerson (Pair p0 p1))
    -- >>> zipMatch (NewPerson p) (NewCake c)
    -- Nothing
    zipMatch :: h # p -> h # q -> Maybe (h # (p :*: q))
    default zipMatch ::
        (Generic1 h, ZipMatch (Rep1 h)) =>
        h # p ->
        h # q ->
        Maybe (h # (p :*: q))
    zipMatch = generic1 . zipMatch . from1

instance ZipMatch Pure where
    {-# INLINE zipMatch #-}
    zipMatch (Pure x) (Pure y) = _Pure # (x :*: y) & Just

instance Eq a => ZipMatch (Const a) where
    {-# INLINE zipMatch #-}
    zipMatch (Const x) (Const y) = Const x <$ guard (x == y)

instance (ZipMatch a, ZipMatch b) => ZipMatch (a :*: b) where
    {-# INLINE zipMatch #-}
    zipMatch (a0 :*: b0) (a1 :*: b1) = (:*:) <$> zipMatch a0 a1 <*> zipMatch b0 b1

instance (ZipMatch a, ZipMatch b) => ZipMatch (a :+: b) where
    {-# INLINE zipMatch #-}
    zipMatch (L1 x) (L1 y) = zipMatch x y <&> L1
    zipMatch (R1 x) (R1 y) = zipMatch x y <&> R1
    zipMatch L1{} R1{} = Nothing
    zipMatch R1{} L1{} = Nothing

deriving newtype instance ZipMatch h => ZipMatch (M1 i m h)
deriving newtype instance ZipMatch h => ZipMatch (Rec1 h)

-- | 'ZipMatch' variant of 'Control.Applicative.liftA2'
{-# INLINE zipMatch2 #-}
zipMatch2 ::
    (ZipMatch h, HFunctor h) =>
    (forall n. HWitness h n -> p # n -> q # n -> r # n) ->
    h # p ->
    h # q ->
    Maybe (h # r)
zipMatch2 f x y = zipMatch x y <&> hmap (\w (a :*: b) -> f w a b)

-- | An 'Applicative' variant of 'zipMatch2'
{-# INLINE zipMatchA #-}
zipMatchA ::
    (Applicative f, ZipMatch h, HTraversable h) =>
    (forall n. HWitness h n -> p # n -> q # n -> f (r # n)) ->
    h # p ->
    h # q ->
    Maybe (f (h # r))
zipMatchA f x y = zipMatch x y <&> htraverse (\w (a :*: b) -> f w a b)

-- | A variant of 'zipMatchA' where the 'Applicative' actions do not contain results
{-# INLINE zipMatch_ #-}
zipMatch_ ::
    (Applicative f, ZipMatch h, HFoldable h) =>
    (forall n. HWitness h n -> p # n -> q # n -> f ()) ->
    h # p ->
    h # q ->
    Maybe (f ())
zipMatch_ f x y = zipMatch x y <&> htraverse_ (\w (a :*: b) -> f w a b)

-- | A variant of 'zipMatch_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@)
{-# INLINE zipMatch1_ #-}
zipMatch1_ ::
    (Applicative f, ZipMatch h, HFoldable h, HNodesConstraint h ((~) n)) =>
    (p # n -> q # n -> f ()) ->
    h # p ->
    h # q ->
    Maybe (f ())
zipMatch1_ f x y = zipMatch x y <&> htraverse1_ (\(a :*: b) -> f a b)