module Ema.Route.Prism.Type where

import Optics.Core (A_Prism, Is, NoIx, Optic', Prism', castOptic, preview, prism', review, (%))

--  DerivingVia prevents us from directly using Prism' here
--  https://stackoverflow.com/q/71489589/55246

{- | Isomorphic to @Prism' s a@, but coercion-friendly.

 Use `fromPrism_` and `toPrism_` to convert between the optics @Prism'@ and this
 @Prism_@.
-}
type Prism_ s a = (a -> s, s -> Maybe a)

-- | Convert a `Prism_` to a @Prism'@.
fromPrism_ :: Prism_ s a -> Prism' s a
fromPrism_ :: Prism_ s a -> Prism' s a
fromPrism_ = ((a -> s) -> (s -> Maybe a) -> Prism' s a)
-> Prism_ s a -> Prism' s a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> s) -> (s -> Maybe a) -> Prism' s a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'

-- | Convert a @Prism'@ to a `Prism_`.
toPrism_ :: Prism' s a -> Prism_ s a
toPrism_ :: Prism' s a -> Prism_ s a
toPrism_ = Prism' s a -> a -> s
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review (Prism' s a -> a -> s)
-> (Prism' s a -> s -> Maybe a) -> Prism' s a -> Prism_ s a
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Prism' s a -> s -> Maybe a
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview

-- | map over the filepath, route and model of the given route prism.
mapRoutePrism ::
  (pr `Is` A_Prism, pf `Is` A_Prism) =>
  -- | How to transform the encoded `FilePath`
  Optic' pf NoIx FilePath FilePath ->
  -- | How to transform the decode route
  Optic' pr NoIx r1 r2 ->
  -- | How to transform (contramap) the resultant model
  (b -> a) ->
  -- | The route prism to fmap.
  (a -> Prism_ FilePath r1) ->
  (b -> Prism_ FilePath r2)
mapRoutePrism :: Optic' pf NoIx FilePath FilePath
-> Optic' pr NoIx r1 r2
-> (b -> a)
-> (a -> Prism_ FilePath r1)
-> b
-> Prism_ FilePath r2
mapRoutePrism (Optic' pf NoIx FilePath FilePath
-> Optic A_Prism NoIx FilePath FilePath FilePath FilePath
forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic -> Optic A_Prism NoIx FilePath FilePath FilePath FilePath
fp) (Optic' pr NoIx r1 r2 -> Optic A_Prism NoIx r1 r1 r2 r2
forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic -> Optic A_Prism NoIx r1 r1 r2 r2
rp) b -> a
m a -> Prism_ FilePath r1
enc =
  Prism' FilePath r2 -> Prism_ FilePath r2
forall s a. Prism' s a -> Prism_ s a
toPrism_ (Prism' FilePath r2 -> Prism_ FilePath r2)
-> (b -> Prism' FilePath r2) -> b -> Prism_ FilePath r2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic A_Prism NoIx FilePath FilePath FilePath FilePath
-> Optic A_Prism NoIx r1 r1 r2 r2
-> (b -> a)
-> (a -> Prism' FilePath r1)
-> b
-> Prism' FilePath r2
forall a b c d x y.
Prism' b a
-> Prism' c d -> (y -> x) -> (x -> Prism' a c) -> y -> Prism' b d
cpmap Optic A_Prism NoIx FilePath FilePath FilePath FilePath
fp Optic A_Prism NoIx r1 r1 r2 r2
rp b -> a
m (Prism_ FilePath r1 -> Prism' FilePath r1
forall s a. Prism_ s a -> Prism' s a
fromPrism_ (Prism_ FilePath r1 -> Prism' FilePath r1)
-> (a -> Prism_ FilePath r1) -> a -> Prism' FilePath r1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Prism_ FilePath r1
enc)
  where
    cpmap ::
      forall a b c d x y.
      Prism' b a ->
      Prism' c d ->
      (y -> x) ->
      (x -> Prism' a c) ->
      (y -> Prism' b d)
    cpmap :: Prism' b a
-> Prism' c d -> (y -> x) -> (x -> Prism' a c) -> y -> Prism' b d
cpmap Prism' b a
p Prism' c d
q y -> x
f x -> Prism' a c
r y
x =
      Prism' b a
p Prism' b a -> Prism' a c -> Optic A_Prism NoIx b b c c
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
% x -> Prism' a c
r (y -> x
f y
x) Optic A_Prism NoIx b b c c -> Prism' c d -> Prism' b d
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
% Prism' c d
q