{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.InvertibleGrammar.Generic
( with
, match
, Coproduct (..)
) where
import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category ((.))
import Data.Functor.Identity
import Data.InvertibleGrammar.Base
import Data.Monoid (First(..))
import Data.Profunctor (Choice(..))
import Data.Profunctor.Unsafe
import Data.Tagged
import Data.Text (pack)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup ((<>))
#endif
import GHC.Generics
with
:: forall a b s t c d f p.
( Generic a
, MkPrismList (Rep a)
, MkStackPrism f
, Rep a ~ M1 D d (M1 C c f)
, StackPrismLhs f t ~ b
, Constructor c
) =>
(Grammar p b (a :- t) -> Grammar p s (a :- t))
-> Grammar p s (a :- t)
with :: (Grammar p b (a :- t) -> Grammar p s (a :- t))
-> Grammar p s (a :- t)
with Grammar p b (a :- t) -> Grammar p s (a :- t)
g =
let PrismList (P prism) = PrismList (M1 D d (M1 C c f)) a
forall a. (Generic a, MkPrismList (Rep a)) => StackPrisms a
mkRevPrismList
name :: [Char]
name = Any c f Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k (m :: Meta -> (* -> *) -> k -> *) (e :: k). m c f e
forall a. HasCallStack => a
undefined :: m c f e)
in Grammar p b (a :- t) -> Grammar p s (a :- t)
g ((b -> a :- t)
-> ((a :- t) -> Either Mismatch b) -> Grammar p b (a :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso
(StackPrism b (a :- t) -> b -> a :- t
forall a b. StackPrism a b -> a -> b
fwd forall t. StackPrism (StackPrismLhs f t) (a :- t)
StackPrism b (a :- t)
prism)
(Either Mismatch b
-> (b -> Either Mismatch b) -> Maybe b -> Either Mismatch b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Mismatch -> Either Mismatch b
forall a b. a -> Either a b
Left (Mismatch -> Either Mismatch b) -> Mismatch -> Either Mismatch b
forall a b. (a -> b) -> a -> b
$ Text -> Mismatch
expected (Text
"constructor " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack [Char]
name)) b -> Either Mismatch b
forall a b. b -> Either a b
Right (Maybe b -> Either Mismatch b)
-> ((a :- t) -> Maybe b) -> (a :- t) -> Either Mismatch b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StackPrism b (a :- t) -> (a :- t) -> Maybe b
forall a b. StackPrism a b -> b -> Maybe a
bkwd forall t. StackPrism (StackPrismLhs f t) (a :- t)
StackPrism b (a :- t)
prism))
match
:: ( Generic a
, MkPrismList (Rep a)
, Match (Rep a) bs t
, bs ~ Coll (Rep a) t
) =>
Coproduct p s bs a t
-> Grammar p s (a :- t)
match :: Coproduct p s bs a t -> Grammar p s (a :- t)
match = (Grammar p s (a :- t), Coproduct p s (Trav (Rep a) bs) a t)
-> Grammar p s (a :- t)
forall a b. (a, b) -> a
fst ((Grammar p s (a :- t), Coproduct p s (Trav (Rep a) bs) a t)
-> Grammar p s (a :- t))
-> (Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav (Rep a) bs) a t))
-> Coproduct p s bs a t
-> Grammar p s (a :- t)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PrismList (Rep a) a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav (Rep a) bs) a t)
forall (f :: * -> *) (bs :: [*]) t a p s.
Match f bs t =>
PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
match' PrismList (Rep a) a
forall a. (Generic a, MkPrismList (Rep a)) => StackPrisms a
mkRevPrismList
data Coproduct p s bs a t where
With
:: (Grammar p b (a :- t) -> Grammar p s (a :- t))
-> Coproduct p s bs a t
-> Coproduct p s (b ': bs) a t
End :: Coproduct p s '[] a t
type family (:++) (as :: [k]) (bs :: [k]) :: [k] where
(:++) (a ': as) bs = a ': (as :++ bs)
(:++) '[] bs = bs
type family Coll (f :: * -> *) (t :: *) :: [*] where
Coll (f :+: g) t = Coll f t :++ Coll g t
Coll (M1 D c f) t = Coll f t
Coll (M1 C c f) t = '[StackPrismLhs f t]
type family Trav (t :: * -> *) (l :: [*]) :: [*] where
Trav (f :+: g) lst = Trav g (Trav f lst)
Trav (M1 D c f) lst = Trav f lst
Trav (M1 C c f) (l ': ls) = ls
class Match (f :: * -> *) bs t where
match' :: PrismList f a
-> Coproduct p s bs a t
-> ( Grammar p s (a :- t)
, Coproduct p s (Trav f bs) a t
)
instance (Match f bs t, Trav f bs ~ '[]) => Match (M1 D c f) bs t where
match' :: PrismList (M1 D c f) a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav (M1 D c f) bs) a t)
match' (PrismList p) = PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
forall (f :: * -> *) (bs :: [*]) t a p s.
Match f bs t =>
PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
match' PrismList f a
p
instance
( Match f bs t
, Match g (Trav f bs) t
) => Match (f :+: g) bs t where
match' :: PrismList (f :+: g) a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav (f :+: g) bs) a t)
match' (p :& q) Coproduct p s bs a t
lst =
let (Grammar p s (a :- t)
gp, Coproduct p s (Trav f bs) a t
rest) = PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
forall (f :: * -> *) (bs :: [*]) t a p s.
Match f bs t =>
PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
match' PrismList f a
p Coproduct p s bs a t
lst
(Grammar p s (a :- t)
qp, Coproduct p s (Trav g (Trav f bs)) a t
rest') = PrismList g a
-> Coproduct p s (Trav f bs) a t
-> (Grammar p s (a :- t), Coproduct p s (Trav g (Trav f bs)) a t)
forall (f :: * -> *) (bs :: [*]) t a p s.
Match f bs t =>
PrismList f a
-> Coproduct p s bs a t
-> (Grammar p s (a :- t), Coproduct p s (Trav f bs) a t)
match' PrismList g a
q Coproduct p s (Trav f bs) a t
rest
in (Grammar p s (a :- t)
gp Grammar p s (a :- t)
-> Grammar p s (a :- t) -> Grammar p s (a :- t)
forall a. Semigroup a => a -> a -> a
<> Grammar p s (a :- t)
qp, Coproduct p s (Trav g (Trav f bs)) a t
Coproduct p s (Trav (f :+: g) bs) a t
rest')
instance (StackPrismLhs f t ~ b, Constructor c) => Match (M1 C c f) (b ': bs) t where
match' :: PrismList (M1 C c f) a
-> Coproduct p s (b : bs) a t
-> (Grammar p s (a :- t),
Coproduct p s (Trav (M1 C c f) (b : bs)) a t)
match' (P prism) (With Grammar p b (a :- t) -> Grammar p s (a :- t)
g Coproduct p s bs a t
rest) =
let name :: [Char]
name = Any c f Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall k (m :: Meta -> (* -> *) -> k -> *) (e :: k). m c f e
forall a. HasCallStack => a
undefined :: m c f e)
p :: b -> a :- t
p = StackPrism b (a :- t) -> b -> a :- t
forall a b. StackPrism a b -> a -> b
fwd forall t. StackPrism (StackPrismLhs f t) (a :- t)
StackPrism b (a :- t)
prism
q :: (a :- t) -> Either Mismatch b
q = Either Mismatch b
-> (b -> Either Mismatch b) -> Maybe b -> Either Mismatch b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Mismatch -> Either Mismatch b
forall a b. a -> Either a b
Left (Mismatch -> Either Mismatch b) -> Mismatch -> Either Mismatch b
forall a b. (a -> b) -> a -> b
$ Text -> Mismatch
expected (Text
"constructor " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack [Char]
name)) b -> Either Mismatch b
forall a b. b -> Either a b
Right (Maybe b -> Either Mismatch b)
-> ((a :- t) -> Maybe b) -> (a :- t) -> Either Mismatch b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StackPrism b (a :- t) -> (a :- t) -> Maybe b
forall a b. StackPrism a b -> b -> Maybe a
bkwd forall t. StackPrism (StackPrismLhs f t) (a :- t)
StackPrism b (a :- t)
prism
in (Grammar p b (a :- t) -> Grammar p s (a :- t)
g (Grammar p b (a :- t) -> Grammar p s (a :- t))
-> Grammar p b (a :- t) -> Grammar p s (a :- t)
forall a b. (a -> b) -> a -> b
$ (b -> a :- t)
-> ((a :- t) -> Either Mismatch b) -> Grammar p b (a :- t)
forall a b p. (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b
PartialIso b -> a :- t
p (a :- t) -> Either Mismatch b
(a :- t) -> Either Mismatch b
q, Coproduct p s bs a t
Coproduct p s (Trav (M1 C c f) (b : bs)) a t
rest)
mkRevPrismList :: (Generic a, MkPrismList (Rep a)) => StackPrisms a
mkRevPrismList :: StackPrisms a
mkRevPrismList = (Rep a Any -> a) -> (a -> Maybe (Rep a Any)) -> StackPrisms a
forall (f :: * -> *) p a q.
MkPrismList f =>
(f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
mkPrismList' Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> Maybe (Rep a Any)
forall a. a -> Maybe a
Just (Rep a Any -> Maybe (Rep a Any))
-> (a -> Rep a Any) -> a -> Maybe (Rep a Any)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from)
type StackPrism a b = forall p f. (Choice p, Applicative f) => p a (f a) -> p b (f b)
stackPrism :: (a -> b) -> (b -> Maybe a) -> StackPrism a b
stackPrism :: (a -> b) -> (b -> Maybe a) -> StackPrism a b
stackPrism a -> b
f b -> Maybe a
g = (b -> Either b a)
-> (Either b (f a) -> f b)
-> p (Either b a) (Either b (f a))
-> p b (f b)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\b
b -> Either b a -> (a -> Either b a) -> Maybe a -> Either b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> Either b a
forall a b. a -> Either a b
Left b
b) a -> Either b a
forall a b. b -> Either a b
Right (b -> Maybe a
g b
b)) ((b -> f b) -> (f a -> f b) -> Either b (f a) -> f b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> f b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) (p (Either b a) (Either b (f a)) -> p b (f b))
-> (p a (f a) -> p (Either b a) (Either b (f a)))
-> p a (f a)
-> p b (f b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p a (f a) -> p (Either b a) (Either b (f a))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
fwd :: StackPrism a b -> a -> b
fwd :: StackPrism a b -> a -> b
fwd StackPrism a b
l = Identity b -> b
forall a. Identity a -> a
runIdentity (Identity b -> b)
-> (Tagged a (Identity a) -> Identity b)
-> Tagged a (Identity a)
-> b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged b (Identity b) -> Identity b
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged b (Identity b) -> Identity b)
-> (Tagged a (Identity a) -> Tagged b (Identity b))
-> Tagged a (Identity a)
-> Identity b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged a (Identity a) -> Tagged b (Identity b)
StackPrism a b
l (Tagged a (Identity a) -> b)
-> (Identity a -> Tagged a (Identity a)) -> Identity a -> b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Identity a -> Tagged a (Identity a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Identity a -> b) -> (a -> Identity a) -> a -> b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# a -> Identity a
forall a. a -> Identity a
Identity
bkwd :: StackPrism a b -> b -> Maybe a
bkwd :: StackPrism a b -> b -> Maybe a
bkwd StackPrism a b
l = First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> (b -> First a) -> b -> Maybe a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Const (First a) b -> First a
forall a k (b :: k). Const a b -> a
getConst (Const (First a) b -> First a)
-> (b -> Const (First a) b) -> b -> First a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> Const (First a) a) -> b -> Const (First a) b
StackPrism a b
l (First a -> Const (First a) a
forall k a (b :: k). a -> Const a b
Const (First a -> Const (First a) a)
-> (a -> First a) -> a -> Const (First a) a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> Maybe a
forall a. a -> Maybe a
Just)
type StackPrisms a = PrismList (Rep a) a
data family PrismList (f :: * -> *) (a :: *)
class MkPrismList (f :: * -> *) where
mkPrismList' :: (f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
data instance PrismList (M1 D c f) a = PrismList (PrismList f a)
instance MkPrismList f => MkPrismList (M1 D c f) where
mkPrismList' :: (M1 D c f p -> a)
-> (a -> Maybe (M1 D c f q)) -> PrismList (M1 D c f) a
mkPrismList' M1 D c f p -> a
f' a -> Maybe (M1 D c f q)
g' = PrismList f a -> PrismList (M1 D c f) a
forall (c :: Meta) (f :: * -> *) a.
PrismList f a -> PrismList (M1 D c f) a
PrismList ((f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
forall (f :: * -> *) p a q.
MkPrismList f =>
(f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
mkPrismList' (M1 D c f p -> a
f' (M1 D c f p -> a) -> (f p -> M1 D c f p) -> f p -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ((M1 D c f q -> f q) -> Maybe (M1 D c f q) -> Maybe (f q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap M1 D c f q -> f q
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (Maybe (M1 D c f q) -> Maybe (f q))
-> (a -> Maybe (M1 D c f q)) -> a -> Maybe (f q)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe (M1 D c f q)
g'))
infixr :&
data instance PrismList (f :+: g) a = PrismList f a :& PrismList g a
instance (MkPrismList f, MkPrismList g) => MkPrismList (f :+: g) where
mkPrismList' :: ((:+:) f g p -> a)
-> (a -> Maybe ((:+:) f g q)) -> PrismList (f :+: g) a
mkPrismList' (:+:) f g p -> a
f' a -> Maybe ((:+:) f g q)
g' = ((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList f a
forall a p q.
((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList f a
f (:+:) f g p -> a
f' a -> Maybe ((:+:) f g q)
g' PrismList f a -> PrismList g a -> PrismList (f :+: g) a
forall (f :: * -> *) (g :: * -> *) a.
PrismList f a -> PrismList g a -> PrismList (f :+: g) a
:& ((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList g a
forall a p q.
((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList g a
g (:+:) f g p -> a
f' a -> Maybe ((:+:) f g q)
g'
where
f :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList f a
f :: ((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList f a
f (:+:) f g p -> a
_f' a -> Maybe ((:+:) f g q)
_g' = (f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
forall (f :: * -> *) p a q.
MkPrismList f =>
(f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
mkPrismList' (\f p
fp -> (:+:) f g p -> a
_f' (f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f p
fp)) ((a -> Maybe ((:+:) f g q)) -> a -> Maybe (f q)
forall a q. (a -> Maybe ((:+:) f g q)) -> a -> Maybe (f q)
matchL a -> Maybe ((:+:) f g q)
_g')
g :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList g a
g :: ((:+:) f g p -> a) -> (a -> Maybe ((:+:) f g q)) -> PrismList g a
g (:+:) f g p -> a
_f' a -> Maybe ((:+:) f g q)
_g' = (g p -> a) -> (a -> Maybe (g q)) -> PrismList g a
forall (f :: * -> *) p a q.
MkPrismList f =>
(f p -> a) -> (a -> Maybe (f q)) -> PrismList f a
mkPrismList' (\g p
gp -> (:+:) f g p -> a
_f' (g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g p
gp)) ((a -> Maybe ((:+:) f g q)) -> a -> Maybe (g q)
forall a q. (a -> Maybe ((:+:) f g q)) -> a -> Maybe (g q)
matchR a -> Maybe ((:+:) f g q)
_g')
matchL :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (f q)
matchL :: (a -> Maybe ((:+:) f g q)) -> a -> Maybe (f q)
matchL a -> Maybe ((:+:) f g q)
_g' a
a = case a -> Maybe ((:+:) f g q)
_g' a
a of
Just (L1 f q
f'') -> f q -> Maybe (f q)
forall a. a -> Maybe a
Just f q
f''
Maybe ((:+:) f g q)
_ -> Maybe (f q)
forall a. Maybe a
Nothing
matchR :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (g q)
matchR :: (a -> Maybe ((:+:) f g q)) -> a -> Maybe (g q)
matchR a -> Maybe ((:+:) f g q)
_g' a
a = case a -> Maybe ((:+:) f g q)
_g' a
a of
Just (R1 g q
g'') -> g q -> Maybe (g q)
forall a. a -> Maybe a
Just g q
g''
Maybe ((:+:) f g q)
_ -> Maybe (g q)
forall a. Maybe a
Nothing
data instance PrismList (M1 C c f) a = P (forall t. StackPrism (StackPrismLhs f t) (a :- t))
instance MkStackPrism f => MkPrismList (M1 C c f) where
mkPrismList' :: (M1 C c f p -> a)
-> (a -> Maybe (M1 C c f q)) -> PrismList (M1 C c f) a
mkPrismList' M1 C c f p -> a
f' a -> Maybe (M1 C c f q)
g' = (forall t. StackPrism (StackPrismLhs f t) (a :- t))
-> PrismList (M1 C c f) a
forall (c :: Meta) (f :: * -> *) a.
(forall t. StackPrism (StackPrismLhs f t) (a :- t))
-> PrismList (M1 C c f) a
P ((StackPrismLhs f t -> a :- t)
-> ((a :- t) -> Maybe (StackPrismLhs f t))
-> StackPrism (StackPrismLhs f t) (a :- t)
forall a b. (a -> b) -> (b -> Maybe a) -> StackPrism a b
stackPrism ((M1 C c f p -> a) -> StackPrismLhs f t -> a :- t
forall a p t. (M1 C c f p -> a) -> StackPrismLhs f t -> a :- t
f M1 C c f p -> a
f') ((a -> Maybe (M1 C c f q)) -> (a :- t) -> Maybe (StackPrismLhs f t)
forall a p t.
(a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (StackPrismLhs f t)
g a -> Maybe (M1 C c f q)
g'))
where
f :: forall a p t. (M1 C c f p -> a) -> StackPrismLhs f t -> a :- t
f :: (M1 C c f p -> a) -> StackPrismLhs f t -> a :- t
f M1 C c f p -> a
_f' StackPrismLhs f t
lhs = (f p -> a) -> (f p :- t) -> a :- t
forall a b t. (a -> b) -> (a :- t) -> b :- t
mapHead (M1 C c f p -> a
_f' (M1 C c f p -> a) -> (f p -> M1 C c f p) -> f p -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) (StackPrismLhs f t -> f p :- t
forall (f :: * -> *) p t.
MkStackPrism f =>
StackPrismLhs f t -> f p :- t
mkR StackPrismLhs f t
lhs)
g :: forall a p t. (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (StackPrismLhs f t)
g :: (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (StackPrismLhs f t)
g a -> Maybe (M1 C c f p)
_g' (a
a :- t
t) = (M1 C c f p -> StackPrismLhs f t)
-> Maybe (M1 C c f p) -> Maybe (StackPrismLhs f t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f p :- t) -> StackPrismLhs f t
forall (f :: * -> *) p t.
MkStackPrism f =>
(f p :- t) -> StackPrismLhs f t
mkL ((f p :- t) -> StackPrismLhs f t)
-> (M1 C c f p -> f p :- t) -> M1 C c f p -> StackPrismLhs f t
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (f p -> t -> f p :- t
forall h t. h -> t -> h :- t
:- t
t) (f p -> f p :- t) -> (M1 C c f p -> f p) -> M1 C c f p -> f p :- t
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. M1 C c f p -> f p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (a -> Maybe (M1 C c f p)
_g' a
a)
type family StackPrismLhs (f :: * -> *) (t :: *) :: *
class MkStackPrism (f :: * -> *) where
mkR :: forall p t. StackPrismLhs f t -> (f p :- t)
mkL :: forall p t. (f p :- t) -> StackPrismLhs f t
type instance StackPrismLhs U1 t = t
instance MkStackPrism U1 where
mkR :: StackPrismLhs U1 t -> U1 p :- t
mkR StackPrismLhs U1 t
t = U1 p
forall k (p :: k). U1 p
U1 U1 p -> t -> U1 p :- t
forall h t. h -> t -> h :- t
:- t
StackPrismLhs U1 t
t
mkL :: (U1 p :- t) -> StackPrismLhs U1 t
mkL (U1 p
U1 :- t
t) = t
StackPrismLhs U1 t
t
type instance StackPrismLhs (K1 i a) t = a :- t
instance MkStackPrism (K1 i a) where
mkR :: StackPrismLhs (K1 i a) t -> K1 i a p :- t
mkR (h :- t) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 a
h K1 i a p -> t -> K1 i a p :- t
forall h t. h -> t -> h :- t
:- t
t
mkL :: (K1 i a p :- t) -> StackPrismLhs (K1 i a) t
mkL (K1 a
h :- t
t) = a
h a -> t -> a :- t
forall h t. h -> t -> h :- t
:- t
t
type instance StackPrismLhs (M1 i c f) t = StackPrismLhs f t
instance MkStackPrism f => MkStackPrism (M1 i c f) where
mkR :: StackPrismLhs (M1 i c f) t -> M1 i c f p :- t
mkR = (f p -> M1 i c f p) -> (f p :- t) -> M1 i c f p :- t
forall a b t. (a -> b) -> (a :- t) -> b :- t
mapHead f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((f p :- t) -> M1 i c f p :- t)
-> (StackPrismLhs f t -> f p :- t)
-> StackPrismLhs f t
-> M1 i c f p :- t
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. StackPrismLhs f t -> f p :- t
forall (f :: * -> *) p t.
MkStackPrism f =>
StackPrismLhs f t -> f p :- t
mkR
mkL :: (M1 i c f p :- t) -> StackPrismLhs (M1 i c f) t
mkL = (f p :- t) -> StackPrismLhs f t
forall (f :: * -> *) p t.
MkStackPrism f =>
(f p :- t) -> StackPrismLhs f t
mkL ((f p :- t) -> StackPrismLhs f t)
-> ((M1 i c f p :- t) -> f p :- t)
-> (M1 i c f p :- t)
-> StackPrismLhs f t
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (M1 i c f p -> f p) -> (M1 i c f p :- t) -> f p :- t
forall a b t. (a -> b) -> (a :- t) -> b :- t
mapHead M1 i c f p -> f p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
type instance StackPrismLhs (f :*: g) t = StackPrismLhs g (StackPrismLhs f t)
instance (MkStackPrism f, MkStackPrism g) => MkStackPrism (f :*: g) where
mkR :: StackPrismLhs (f :*: g) t -> (:*:) f g p :- t
mkR StackPrismLhs (f :*: g) t
t = (f p
hg f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
hf) (:*:) f g p -> t -> (:*:) f g p :- t
forall h t. h -> t -> h :- t
:- t
tg
where
g p
hf :- StackPrismLhs f t
tf = StackPrismLhs g (StackPrismLhs f t) -> g p :- StackPrismLhs f t
forall (f :: * -> *) p t.
MkStackPrism f =>
StackPrismLhs f t -> f p :- t
mkR StackPrismLhs g (StackPrismLhs f t)
StackPrismLhs (f :*: g) t
t
f p
hg :- t
tg = StackPrismLhs f t -> f p :- t
forall (f :: * -> *) p t.
MkStackPrism f =>
StackPrismLhs f t -> f p :- t
mkR StackPrismLhs f t
tf
mkL :: ((:*:) f g p :- t) -> StackPrismLhs (f :*: g) t
mkL ((f p
hf :*: g p
hg) :- t
t) = (g p :- StackPrismLhs f t) -> StackPrismLhs g (StackPrismLhs f t)
forall (f :: * -> *) p t.
MkStackPrism f =>
(f p :- t) -> StackPrismLhs f t
mkL (g p
hg g p -> StackPrismLhs f t -> g p :- StackPrismLhs f t
forall h t. h -> t -> h :- t
:- (f p :- t) -> StackPrismLhs f t
forall (f :: * -> *) p t.
MkStackPrism f =>
(f p :- t) -> StackPrismLhs f t
mkL (f p
hf f p -> t -> f p :- t
forall h t. h -> t -> h :- t
:- t
t))
mapHead :: (a -> b) -> (a :- t) -> (b :- t)
mapHead :: (a -> b) -> (a :- t) -> b :- t
mapHead a -> b
f (a
h :- t
t) = a -> b
f a
h b -> t -> b :- t
forall h t. h -> t -> h :- t
:- t
t