{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Dep.Phases (
Phased (..),
liftAH,
pullPhase,
mapPhase,
liftA2Phase,
(>>=),
(>>),
Compose (..),
) where
import Control.Applicative
import Data.Coerce
import Data.Function (fix)
import Data.Functor (($>), (<&>))
import Data.Functor.Identity
import Data.Kind
import Data.Proxy
import Data.String
import Data.Type.Equality (type (==))
import Data.Typeable
import GHC.Generics qualified as G
import GHC.Records
import GHC.TypeLits
import Data.Functor.Compose
import Prelude (Functor, (<$>), (<$), ($), (.))
type Phased :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint
class Phased (env_ :: (Type -> Type) -> (Type -> Type) -> Type) where
traverseH ::
forall
(h :: Type -> Type)
(f :: Type -> Type)
(g :: Type -> Type)
(m :: Type -> Type).
(
Applicative f,
Typeable f,
Typeable g,
Typeable h,
Typeable m
) =>
(forall x. Typeable x => h x -> f (g x)) ->
env_ h m ->
f (env_ g m)
default traverseH ::
forall
(h :: Type -> Type)
(f :: Type -> Type)
(g :: Type -> Type)
(m :: Type -> Type).
( Applicative f,
Typeable f,
Typeable g,
Typeable h,
Typeable m,
G.Generic (env_ h m),
G.Generic (env_ g m),
GTraverseH h g (G.Rep (env_ h m)) (G.Rep (env_ g m))
) =>
(forall x. Typeable x => h x -> f (g x)) ->
env_ h m ->
f (env_ g m)
traverseH forall x. Typeable x => h x -> f (g x)
t env_ h m
env = forall a x. Generic a => Rep a x -> a
G.to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (h :: k -> *) (g :: k -> *) (env :: k -> *)
(env' :: k -> *) (f :: * -> *) (x :: k).
(GTraverseH h g env env', Applicative f) =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> env x -> f (env' x)
gTraverseH forall x. Typeable x => h x -> f (g x)
t (forall a x. Generic a => a -> Rep a x
G.from env_ h m
env)
liftA2H ::
forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type).
( Typeable a,
Typeable f,
Typeable f',
Typeable m
) =>
(forall x. Typeable x => a x -> f x -> f' x) ->
env_ a m ->
env_ f m ->
env_ f' m
default liftA2H ::
forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) m.
( Typeable a,
Typeable f,
Typeable f',
Typeable m,
G.Generic (env_ a m),
G.Generic (env_ f m),
G.Generic (env_ f' m),
GLiftA2Phase a f f' (G.Rep (env_ a m)) (G.Rep (env_ f m)) (G.Rep (env_ f' m))
) =>
(forall x. Typeable x => a x -> f x -> f' x) ->
env_ a m ->
env_ f m ->
env_ f' m
liftA2H forall x. Typeable x => a x -> f x -> f' x
f env_ a m
enva env_ f m
env = forall a x. Generic a => Rep a x -> a
G.to (forall {k} {k} (a :: k -> *) (f :: k -> *) (f' :: k -> *)
(enva :: k -> *) (env :: k -> *) (env' :: k -> *) (x :: k).
GLiftA2Phase a f f' enva env env' =>
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> enva x -> env x -> env' x
gLiftA2Phase forall x. Typeable x => a x -> f x -> f' x
f (forall a x. Generic a => a -> Rep a x
G.from env_ a m
enva) (forall a x. Generic a => a -> Rep a x
G.from env_ f m
env))
liftAH ::
forall deps_ phases phases' m.
(Phased deps_, Typeable phases, Typeable phases', Typeable m) =>
(forall x. Typeable x => phases x -> phases' x) ->
deps_ phases m ->
deps_ phases' m
liftAH :: forall (deps_ :: (* -> *) -> (* -> *) -> *) (phases :: * -> *)
(phases' :: * -> *) (m :: * -> *).
(Phased deps_, Typeable phases, Typeable phases', Typeable m) =>
(forall x. Typeable x => phases x -> phases' x)
-> deps_ phases m -> deps_ phases' m
liftAH forall x. Typeable x => phases x -> phases' x
tweak =
forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (env_ :: (* -> *) -> (* -> *) -> *) (h :: * -> *)
(f :: * -> *) (g :: * -> *) (m :: * -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable h,
Typeable m) =>
(forall x. Typeable x => h x -> f (g x))
-> env_ h m -> f (env_ g m)
traverseH (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. Typeable x => phases x -> phases' x
tweak)
pullPhase ::
forall (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_.
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) =>
env_ (Compose f g) m ->
f (env_ g m)
pullPhase :: forall (f :: * -> *) (g :: * -> *) (m :: * -> *)
(env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) =>
env_ (Compose f g) m -> f (env_ g m)
pullPhase = forall (env_ :: (* -> *) -> (* -> *) -> *) (h :: * -> *)
(f :: * -> *) (g :: * -> *) (m :: * -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable h,
Typeable m) =>
(forall x. Typeable x => h x -> f (g x))
-> env_ h m -> f (env_ g m)
traverseH @env_ forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
mapPhase ::
forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_.
(Phased env_, Typeable f, Typeable f', Typeable g, Typeable m) =>
(forall x. Typeable x => f x -> f' x) ->
env_ (Compose f g) m ->
env_ (Compose f' g) m
mapPhase :: forall (f :: * -> *) (f' :: * -> *) (g :: * -> *) (m :: * -> *)
(env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Typeable f, Typeable f', Typeable g, Typeable m) =>
(forall x. Typeable x => f x -> f' x)
-> env_ (Compose f g) m -> env_ (Compose f' g) m
mapPhase forall x. Typeable x => f x -> f' x
f env_ (Compose f g) m
env = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (env_ :: (* -> *) -> (* -> *) -> *) (h :: * -> *)
(f :: * -> *) (g :: * -> *) (m :: * -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable h,
Typeable m) =>
(forall x. Typeable x => h x -> f (g x))
-> env_ h m -> f (env_ g m)
traverseH @env_ (\(Compose f (g x)
fg) -> forall a. a -> Identity a
Identity (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall x. Typeable x => f x -> f' x
f f (g x)
fg))) env_ (Compose f g) m
env
liftA2Phase ::
forall (a :: Type -> Type) (f' :: Type -> Type) (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_.
(Phased env_, Typeable a, Typeable f, Typeable f', Typeable g, Typeable m) =>
(forall x. Typeable x => a x -> f x -> f' x) ->
env_ (Compose a g) m ->
env_ (Compose f g) m ->
env_ (Compose f' g) m
liftA2Phase :: forall (a :: * -> *) (f' :: * -> *) (f :: * -> *) (g :: * -> *)
(m :: * -> *) (env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Typeable a, Typeable f, Typeable f', Typeable g,
Typeable m) =>
(forall x. Typeable x => a x -> f x -> f' x)
-> env_ (Compose a g) m
-> env_ (Compose f g) m
-> env_ (Compose f' g) m
liftA2Phase forall x. Typeable x => a x -> f x -> f' x
f = forall (env_ :: (* -> *) -> (* -> *) -> *) (a :: * -> *)
(f :: * -> *) (f' :: * -> *) (m :: * -> *).
(Phased env_, Typeable a, Typeable f, Typeable f', Typeable m) =>
(forall x. Typeable x => a x -> f x -> f' x)
-> env_ a m -> env_ f m -> env_ f' m
liftA2H @env_ (\(Compose a (g x)
fa) (Compose f (g x)
fg) -> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall x. Typeable x => a x -> f x -> f' x
f a (g x)
fa f (g x)
fg))
class GTraverseH h g env env' | env -> h, env' -> g where
gTraverseH :: Applicative f => (forall x. Typeable x => h x -> f (g x)) -> env x -> f (env' x)
instance
(GTraverseH h g fields fields') =>
GTraverseH
h
g
(G.D1 metaData (G.C1 metaCons fields))
(G.D1 metaData (G.C1 metaCons fields'))
where
gTraverseH :: forall (f :: * -> *) (x :: k).
Applicative f =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> D1 metaData (C1 metaCons fields) x
-> f (D1 metaData (C1 metaCons fields') x)
gTraverseH forall (x :: k). Typeable x => h x -> f (g x)
t (G.M1 (G.M1 fields x
fields)) =
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (h :: k -> *) (g :: k -> *) (env :: k -> *)
(env' :: k -> *) (f :: * -> *) (x :: k).
(GTraverseH h g env env', Applicative f) =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> env x -> f (env' x)
gTraverseH @h @g forall (x :: k). Typeable x => h x -> f (g x)
t fields x
fields
instance
( GTraverseH h g left left',
GTraverseH h g right right'
) =>
GTraverseH h g (left G.:*: right) (left' G.:*: right')
where
gTraverseH :: forall (f :: * -> *) (x :: k).
Applicative f =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> (:*:) left right x -> f ((:*:) left' right' x)
gTraverseH forall (x :: k). Typeable x => h x -> f (g x)
t (left x
left G.:*: right x
right) =
let left' :: f (left' x)
left' = forall {k} {k} (h :: k -> *) (g :: k -> *) (env :: k -> *)
(env' :: k -> *) (f :: * -> *) (x :: k).
(GTraverseH h g env env', Applicative f) =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> env x -> f (env' x)
gTraverseH @h @g forall (x :: k). Typeable x => h x -> f (g x)
t left x
left
right' :: f (right' x)
right' = forall {k} {k} (h :: k -> *) (g :: k -> *) (env :: k -> *)
(env' :: k -> *) (f :: * -> *) (x :: k).
(GTraverseH h g env env', Applicative f) =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> env x -> f (env' x)
gTraverseH @h @g forall (x :: k). Typeable x => h x -> f (g x)
t right x
right
in forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(G.:*:) f (left' x)
left' f (right' x)
right'
instance
Typeable bean =>
GTraverseH
h
g
(G.S1 metaSel (G.Rec0 (h bean)))
(G.S1 metaSel (G.Rec0 (g bean)))
where
gTraverseH :: forall (f :: * -> *) (x :: k).
Applicative f =>
(forall (x :: k). Typeable x => h x -> f (g x))
-> S1 metaSel (Rec0 (h bean)) x -> f (S1 metaSel (Rec0 (g bean)) x)
gTraverseH forall (x :: k). Typeable x => h x -> f (g x)
t (G.M1 (G.K1 h bean
hbean)) =
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
G.K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (x :: k). Typeable x => h x -> f (g x)
t h bean
hbean
class GLiftA2Phase a f f' enva env env' | enva -> a, env -> f, env' -> f' where
gLiftA2Phase :: (forall r. Typeable r => a r -> f r -> f' r) -> enva x -> env x -> env' x
instance
GLiftA2Phase a f f' fieldsa fields fields' =>
GLiftA2Phase
a
f
f'
(G.D1 metaData (G.C1 metaCons fieldsa))
(G.D1 metaData (G.C1 metaCons fields))
(G.D1 metaData (G.C1 metaCons fields'))
where
gLiftA2Phase :: forall (x :: k).
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> D1 metaData (C1 metaCons fieldsa) x
-> D1 metaData (C1 metaCons fields) x
-> D1 metaData (C1 metaCons fields') x
gLiftA2Phase forall (r :: k). Typeable r => a r -> f r -> f' r
f (G.M1 (G.M1 fieldsa x
fieldsa)) (G.M1 (G.M1 fields x
fields)) =
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (forall {k} {k} (a :: k -> *) (f :: k -> *) (f' :: k -> *)
(enva :: k -> *) (env :: k -> *) (env' :: k -> *) (x :: k).
GLiftA2Phase a f f' enva env env' =>
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> enva x -> env x -> env' x
gLiftA2Phase @a @f @f' forall (r :: k). Typeable r => a r -> f r -> f' r
f fieldsa x
fieldsa fields x
fields))
instance
( GLiftA2Phase a f f' lefta left left',
GLiftA2Phase a f f' righta right right'
) =>
GLiftA2Phase a f f' (lefta G.:*: righta) (left G.:*: right) (left' G.:*: right')
where
gLiftA2Phase :: forall (x :: k).
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> (:*:) lefta righta x
-> (:*:) left right x
-> (:*:) left' right' x
gLiftA2Phase forall (r :: k). Typeable r => a r -> f r -> f' r
f (lefta x
lefta G.:*: righta x
righta) (left x
left G.:*: right x
right) =
let left' :: left' x
left' = forall {k} {k} (a :: k -> *) (f :: k -> *) (f' :: k -> *)
(enva :: k -> *) (env :: k -> *) (env' :: k -> *) (x :: k).
GLiftA2Phase a f f' enva env env' =>
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> enva x -> env x -> env' x
gLiftA2Phase @a @f @f' forall (r :: k). Typeable r => a r -> f r -> f' r
f lefta x
lefta left x
left
right' :: right' x
right' = forall {k} {k} (a :: k -> *) (f :: k -> *) (f' :: k -> *)
(enva :: k -> *) (env :: k -> *) (env' :: k -> *) (x :: k).
GLiftA2Phase a f f' enva env env' =>
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> enva x -> env x -> env' x
gLiftA2Phase @a @f @f' forall (r :: k). Typeable r => a r -> f r -> f' r
f righta x
righta right x
right
in forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(G.:*:) left' x
left' right' x
right'
instance
Typeable bean =>
GLiftA2Phase
a
f
f'
(G.S1 metaSel (G.Rec0 (a bean)))
(G.S1 metaSel (G.Rec0 (f bean)))
(G.S1 metaSel (G.Rec0 (f' bean)))
where
gLiftA2Phase :: forall (x :: k).
(forall (r :: k). Typeable r => a r -> f r -> f' r)
-> S1 metaSel (Rec0 (a bean)) x
-> S1 metaSel (Rec0 (f bean)) x
-> S1 metaSel (Rec0 (f' bean)) x
gLiftA2Phase forall (r :: k). Typeable r => a r -> f r -> f' r
f (G.M1 (G.K1 a bean
abean)) (G.M1 (G.K1 f bean
fgbean)) =
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (forall k i c (p :: k). c -> K1 i c p
G.K1 (forall (r :: k). Typeable r => a r -> f r -> f' r
f a bean
abean f bean
fgbean))
(>>=) :: Functor f => f x -> (x -> g y) -> Compose f g y
f x
f >>= :: forall {k1} (f :: * -> *) x (g :: k1 -> *) (y :: k1).
Functor f =>
f x -> (x -> g y) -> Compose f g y
>>= x -> g y
k = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (x -> g y
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x
f)
(>>) :: Functor f => f x -> g y -> Compose f g y
f x
f >> :: forall {k1} (f :: * -> *) x (g :: k1 -> *) (y :: k1).
Functor f =>
f x -> g y -> Compose f g y
>> g y
g = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (g y
g forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f x
f)