{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Hyper.Diff
( diff
, Diff (..)
, _CommonBody
, _CommonSubTree
, _Different
, CommonBody (..)
, anns
, val
, foldDiffs
, diffP
, DiffP (..)
, _CommonBodyP
, _CommonSubTreeP
, _DifferentP
, foldDiffsP
) where
import Hyper
import Hyper.Class.ZipMatch (ZipMatch (..))
import Hyper.Internal.Prelude
import Hyper.Recurse
data Diff a b e
= CommonSubTree (Ann (a :*: b) e)
| CommonBody (CommonBody a b e)
| Different ((Ann a :*: Ann b) e)
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Rep (Diff a b e) x -> Diff a b e
forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Diff a b e -> Rep (Diff a b e) x
$cto :: forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Rep (Diff a b e) x -> Diff a b e
$cfrom :: forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Diff a b e -> Rep (Diff a b e) x
Generic)
data CommonBody a b e = MkCommonBody
{ forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
CommonBody a b e -> (:*:) a b e
_anns :: (a :*: b) e
, forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
CommonBody a b e -> e :# Diff a b
_val :: e :# Diff a b
}
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Rep (CommonBody a b e) x -> CommonBody a b e
forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
CommonBody a b e -> Rep (CommonBody a b e) x
$cto :: forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
Rep (CommonBody a b e) x -> CommonBody a b e
$cfrom :: forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType) x.
CommonBody a b e -> Rep (CommonBody a b e) x
Generic)
makePrisms ''Diff
makeLenses ''CommonBody
diff ::
forall t a b.
(Recursively ZipMatch t, RTraversable t) =>
Ann a # t ->
Ann b # t ->
Diff a b # t
diff :: forall (t :: AHyperType -> *) (a :: AHyperType -> *)
(b :: AHyperType -> *).
(Recursively ZipMatch t, RTraversable t) =>
(Ann a # t) -> (Ann b # t) -> Diff a b # t
diff x :: Ann a # t
x@(Ann a ('AHyperType t)
xA 'AHyperType t :# Ann a
xB) y :: Ann b # t
y@(Ann b ('AHyperType t)
yA 'AHyperType t :# Ann b
yB) =
case forall (h :: AHyperType -> *) (p :: AHyperType -> *)
(q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch 'AHyperType t :# Ann a
xB 'AHyperType t :# Ann b
yB of
Maybe (t # (Ann a :*: Ann b))
Nothing -> forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
(:*:) (Ann a) (Ann b) e -> Diff a b e
Different (Ann a # t
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Ann b # t
y)
Just t # (Ann a :*: Ann b)
match ->
case forall (f :: * -> *) (h :: AHyperType -> *) (p :: AHyperType -> *)
(q :: AHyperType -> *).
(Applicative f, HTraversable h) =>
(forall (n :: AHyperType -> *).
HWitness h n -> (p # n) -> f (q # n))
-> (h # p) -> f (h # q)
htraverse (forall a b. a -> b -> a
const (forall s a. s -> Getting (First a) s a -> Maybe a
^? forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
Prism' (Diff a b e) (Ann (a :*: b) e)
_CommonSubTree)) t # Diff a b
sub of
Maybe (t # Ann (a :*: b))
Nothing -> forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
(:*:) a b e -> (e :# Diff a b) -> CommonBody a b e
MkCommonBody (a ('AHyperType t)
xA forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b ('AHyperType t)
yA) t # Diff a b
sub forall a b. a -> (a -> b) -> b
& forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
CommonBody a b e -> Diff a b e
CommonBody
Just t # Ann (a :*: b)
r -> forall (a :: AHyperType -> *) (h :: AHyperType).
a h -> (h :# Ann a) -> Ann a h
Ann (a ('AHyperType t)
xA forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b ('AHyperType t)
yA) t # Ann (a :*: b)
r forall a b. a -> (a -> b) -> b
& forall (a :: AHyperType -> *) (b :: AHyperType -> *)
(e :: AHyperType).
Ann (a :*: b) e -> Diff a b e
CommonSubTree
where
sub :: t # Diff a b
sub =
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
(q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap
( forall {k} (t :: k). Proxy t
Proxy @(Recursively ZipMatch) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
forall {k} (t :: k). Proxy t
Proxy @RTraversable forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#>
\(Ann a ('AHyperType n)
xC :*: Ann b ('AHyperType n)
yC) -> forall (t :: AHyperType -> *) (a :: AHyperType -> *)
(b :: AHyperType -> *).
(Recursively ZipMatch t, RTraversable t) =>
(Ann a # t) -> (Ann b # t) -> Diff a b # t
diff Ann a ('AHyperType n)
xC Ann b ('AHyperType n)
yC
)
t # (Ann a :*: Ann b)
match
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
(Recursive c, HNodes h, c h) =>
proxy (c h) -> Dict (HNodesConstraint h c)
recurse (forall {k} (t :: k). Proxy t
Proxy @(RTraversable t))
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(ZipMatch t))
foldDiffs ::
forall r h a b.
(Monoid r, Recursively HFoldable h) =>
(forall n. HRecWitness h n -> Ann a # n -> Ann b # n -> r) ->
Diff a b # h ->
r
foldDiffs :: forall r (h :: AHyperType -> *) (a :: AHyperType -> *)
(b :: AHyperType -> *).
(Monoid r, Recursively HFoldable h) =>
(forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r)
-> (Diff a b # h) -> r
foldDiffs forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r
_ CommonSubTree{} = forall a. Monoid a => a
mempty
foldDiffs forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r
f (Different (Ann a ('AHyperType h)
x :*: Ann b ('AHyperType h)
y)) = forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r
f forall (h :: AHyperType -> *). HRecWitness h h
HRecSelf Ann a ('AHyperType h)
x Ann b ('AHyperType h)
y
foldDiffs forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r
f (CommonBody (MkCommonBody (:*:) a b ('AHyperType h)
_ 'AHyperType h :# Diff a b
x)) =
forall (h :: AHyperType -> *) a (p :: AHyperType -> *).
(HFoldable h, Monoid a) =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap
( forall {k} (t :: k). Proxy t
Proxy @(Recursively HFoldable) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
\HWitness h n
w -> forall r (h :: AHyperType -> *) (a :: AHyperType -> *)
(b :: AHyperType -> *).
(Monoid r, Recursively HFoldable h) =>
(forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r)
-> (Diff a b # h) -> r
foldDiffs (forall (n :: AHyperType -> *).
HRecWitness h n -> (Ann a # n) -> (Ann b # n) -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (c :: AHyperType -> *)
(n :: AHyperType -> *).
HWitness h c -> HRecWitness c n -> HRecWitness h n
HRecSub HWitness h n
w)
)
'AHyperType h :# Diff a b
x
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HFoldable h))
data DiffP h
= CommonSubTreeP (HPlain (GetHyperType h))
| CommonBodyP (h :# DiffP)
| DifferentP (HPlain (GetHyperType h)) (HPlain (GetHyperType h))
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (h :: AHyperType) x. Rep (DiffP h) x -> DiffP h
forall (h :: AHyperType) x. DiffP h -> Rep (DiffP h) x
$cto :: forall (h :: AHyperType) x. Rep (DiffP h) x -> DiffP h
$cfrom :: forall (h :: AHyperType) x. DiffP h -> Rep (DiffP h) x
Generic)
makePrisms ''DiffP
diffP ::
forall h.
(Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) =>
HPlain h ->
HPlain h ->
DiffP # h
diffP :: forall (h :: AHyperType -> *).
(Recursively ZipMatch h, Recursively HasHPlain h,
RTraversable h) =>
HPlain h -> HPlain h -> DiffP # h
diffP HPlain h
x HPlain h
y =
forall (h :: AHyperType -> *).
(Recursively ZipMatch h, Recursively HasHPlain h,
RTraversable h) =>
(Pure # h) -> (Pure # h) -> DiffP # h
diffPH (HPlain h
x forall s a. s -> Getting a s a -> a
^. forall (h :: AHyperType -> *).
HasHPlain h =>
Iso' (HPlain h) (Pure # h)
hPlain) (HPlain h
y forall s a. s -> Getting a s a -> a
^. forall (h :: AHyperType -> *).
HasHPlain h =>
Iso' (HPlain h) (Pure # h)
hPlain)
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HasHPlain h))
diffPH ::
forall h.
(Recursively ZipMatch h, Recursively HasHPlain h, RTraversable h) =>
Pure # h ->
Pure # h ->
DiffP # h
diffPH :: forall (h :: AHyperType -> *).
(Recursively ZipMatch h, Recursively HasHPlain h,
RTraversable h) =>
(Pure # h) -> (Pure # h) -> DiffP # h
diffPH Pure # h
x Pure # h
y =
case forall (h :: AHyperType -> *) (p :: AHyperType -> *)
(q :: AHyperType -> *).
ZipMatch h =>
(h # p) -> (h # q) -> Maybe (h # (p :*: q))
zipMatch (Pure # h
x forall s a. s -> Getting a s a -> a
^. forall (h :: AHyperType -> *) (j :: AHyperType -> *).
Iso (Pure # h) (Pure # j) (h # Pure) (j # Pure)
_Pure) (Pure # h
y forall s a. s -> Getting a s a -> a
^. forall (h :: AHyperType -> *) (j :: AHyperType -> *).
Iso (Pure # h) (Pure # j) (h # Pure) (j # Pure)
_Pure) of
Maybe (h # (Pure :*: Pure))
Nothing -> forall (h :: AHyperType).
HPlain (GetHyperType h) -> HPlain (GetHyperType h) -> DiffP h
DifferentP (forall (h :: AHyperType -> *).
HasHPlain h =>
Iso' (HPlain h) (Pure # h)
hPlain forall t b. AReview t b -> b -> t
# Pure # h
x) (forall (h :: AHyperType -> *).
HasHPlain h =>
Iso' (HPlain h) (Pure # h)
hPlain forall t b. AReview t b -> b -> t
# Pure # h
y)
Just h # (Pure :*: Pure)
match ->
case forall (f :: * -> *) (h :: AHyperType -> *) (m :: AHyperType -> *).
(Applicative f, HFoldable h) =>
(forall (c :: AHyperType -> *). HWitness h c -> (m # c) -> f ())
-> (h # m) -> f ()
htraverse_ (forall a b. a -> b -> a
const ((() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting (First a) s a -> Maybe a
^? forall (h :: AHyperType).
Prism' (DiffP h) (HPlain (GetHyperType h))
_CommonSubTreeP))) h # DiffP
sub of
Maybe ()
Nothing -> forall (h :: AHyperType). (h :# DiffP) -> DiffP h
CommonBodyP h # DiffP
sub
Just () -> forall (h :: AHyperType).
Prism' (DiffP h) (HPlain (GetHyperType h))
_CommonSubTreeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *).
HasHPlain h =>
Iso' (HPlain h) (Pure # h)
hPlain forall t b. AReview t b -> b -> t
# Pure # h
x
where
sub :: h # DiffP
sub =
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
(q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap
( forall {k} (t :: k). Proxy t
Proxy @(Recursively ZipMatch) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
forall {k} (t :: k). Proxy t
Proxy @(Recursively HasHPlain) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
forall {k} (t :: k). Proxy t
Proxy @RTraversable forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#>
\(Pure ('AHyperType n)
xC :*: Pure ('AHyperType n)
yC) -> forall (h :: AHyperType -> *).
(Recursively ZipMatch h, Recursively HasHPlain h,
RTraversable h) =>
(Pure # h) -> (Pure # h) -> DiffP # h
diffPH Pure ('AHyperType n)
xC Pure ('AHyperType n)
yC
)
h # (Pure :*: Pure)
match
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
(Recursive c, HNodes h, c h) =>
proxy (c h) -> Dict (HNodesConstraint h c)
recurse (forall {k} (t :: k). Proxy t
Proxy @(RTraversable h))
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(ZipMatch h))
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HasHPlain h))
makeCommonInstances [''Diff, ''CommonBody, ''DiffP]
foldDiffsP ::
forall r h.
(Monoid r, Recursively HFoldable h, Recursively HasHPlain h) =>
(forall n. HasHPlain n => HRecWitness h n -> HPlain n -> HPlain n -> r) ->
DiffP # h ->
r
foldDiffsP :: forall r (h :: AHyperType -> *).
(Monoid r, Recursively HFoldable h, Recursively HasHPlain h) =>
(forall (n :: AHyperType -> *).
HasHPlain n =>
HRecWitness h n -> HPlain n -> HPlain n -> r)
-> (DiffP # h) -> r
foldDiffsP forall (n :: AHyperType -> *).
HasHPlain n =>
HRecWitness h n -> HPlain n -> HPlain n -> r
f =
\case
CommonSubTreeP{} -> forall a. Monoid a => a
mempty
DifferentP HPlain (GetHyperType ('AHyperType h))
x HPlain (GetHyperType ('AHyperType h))
y -> forall (n :: AHyperType -> *).
HasHPlain n =>
HRecWitness h n -> HPlain n -> HPlain n -> r
f forall (h :: AHyperType -> *). HRecWitness h h
HRecSelf HPlain (GetHyperType ('AHyperType h))
x HPlain (GetHyperType ('AHyperType h))
y
CommonBodyP 'AHyperType h :# DiffP
x ->
forall (h :: AHyperType -> *) a (p :: AHyperType -> *).
(HFoldable h, Monoid a) =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap
( forall {k} (t :: k). Proxy t
Proxy @(Recursively HFoldable) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
forall {k} (t :: k). Proxy t
Proxy @(Recursively HasHPlain) forall (h :: AHyperType -> *)
(c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
\HWitness h n
w -> forall r (h :: AHyperType -> *).
(Monoid r, Recursively HFoldable h, Recursively HasHPlain h) =>
(forall (n :: AHyperType -> *).
HasHPlain n =>
HRecWitness h n -> HPlain n -> HPlain n -> r)
-> (DiffP # h) -> r
foldDiffsP (forall (n :: AHyperType -> *).
HasHPlain n =>
HRecWitness h n -> HPlain n -> HPlain n -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (c :: AHyperType -> *)
(n :: AHyperType -> *).
HWitness h c -> HRecWitness c n -> HRecWitness h n
HRecSub HWitness h n
w)
)
'AHyperType h :# DiffP
x
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HFoldable h))
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
(h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HasHPlain h))