-- | Compiling/normalizing patches using 'Compare'.

{-# LANGUAGE AllowAmbiguousTypes #-}

module StreamPatch.Patch.Compile where

import StreamPatch.Patch
import StreamPatch.Patch.Compare qualified as Compare
import StreamPatch.Patch.Compare ( Compare(..), Via(..), EqualityCheck(..) )

import StreamPatch.HFunctorList
import Optics
import Data.Generics.Product.Any
import Data.Vinyl
import Data.Vinyl.TypeLevel ( RIndex )

compilePatch
    :: forall v a s f f' fs fs' i
    .  ( Compare v a
       , f  ~ Compare.Meta ('ViaEq 'Exact)
       , f' ~ Compare.Meta v
       , RElem f fs i
       , RecElem Rec f f' fs fs' i
       , i ~ RIndex f fs
       )
    => Patch s fs  a
    -> Patch s fs' a
compilePatch :: forall (v :: Via) a s (f :: * -> *) (f' :: * -> *) (fs :: [* -> *])
       (fs' :: [* -> *]) (i :: Nat).
(Compare v a, f ~ Meta ('ViaEq 'Exact), f' ~ Meta v, RElem f fs i,
 RecElem Rec f f' fs fs' i, i ~ RIndex f fs) =>
Patch s fs a -> Patch s fs' a
compilePatch = forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over ((forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
the @"patchMeta") forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall {k} (f :: k -> *) (f' :: k -> *) (fs :: [k -> *])
       (fs' :: [k -> *]) (a :: k) s t.
(RecElem Rec f f' fs fs' (RIndex f fs), RElem f fs (RIndex f fs),
 s ~ HFunctorList fs a, t ~ HFunctorList fs' a) =>
Lens s t (f a) (f' a)
hflLens) (forall (v :: Via) a.
Compare v a =>
Meta ('ViaEq 'Exact) a -> Meta v a
compileCompareMeta @v)

compileCompareMeta
    :: forall v a. Compare v a
    => Compare.Meta ('ViaEq 'Exact) a
    -> Compare.Meta v a
compileCompareMeta :: forall (v :: Via) a.
Compare v a =>
Meta ('ViaEq 'Exact) a -> Meta v a
compileCompareMeta (Compare.Meta Maybe (CompareRep ('ViaEq 'Exact) a)
cmp) =
    forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Compare.Meta forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (v :: Via) a. Compare v a => a -> CompareRep v a
toCompareRep @v) Maybe (CompareRep ('ViaEq 'Exact) a)
cmp