{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BlockArguments #-}
module Dep.Constructor
(
Constructor,
constructor,
lmapConstructor,
fixEnv,
AccumConstructor,
accumConstructor,
accumConstructor_,
_accumConstructor,
_accumConstructor_,
lmapAccumConstructor,
fixEnvAccum,
arr
)
where
import Control.Applicative
import Data.Bifunctor (second)
import Data.Coerce
import Data.Function (fix)
import Data.Kind
import Data.Typeable
import Dep.Phases
import Control.Category (Category)
import Control.Category qualified
import Control.Arrow
import Data.Functor.Identity
newtype Constructor (deps :: Type) component
= Constructor (deps -> component)
deriving stock forall a b. a -> Constructor deps b -> Constructor deps a
forall a b. (a -> b) -> Constructor deps a -> Constructor deps b
forall deps a b. a -> Constructor deps b -> Constructor deps a
forall deps a b.
(a -> b) -> Constructor deps a -> Constructor deps b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Constructor deps b -> Constructor deps a
$c<$ :: forall deps a b. a -> Constructor deps b -> Constructor deps a
fmap :: forall a b. (a -> b) -> Constructor deps a -> Constructor deps b
$cfmap :: forall deps a b.
(a -> b) -> Constructor deps a -> Constructor deps b
Functor
deriving newtype instance Category Constructor
deriving newtype instance Arrow Constructor
deriving newtype instance Applicative (Constructor deps)
constructor ::
forall deps component.
(deps -> component) ->
Constructor deps component
constructor :: forall b c. (b -> c) -> Constructor b c
constructor = forall b c. (b -> c) -> Constructor b c
Constructor
newtype AccumConstructor (accum :: Type) (deps :: Type) component
= AccumConstructor ((accum, deps) -> (accum, component))
deriving stock forall a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
forall a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
forall accum deps a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
forall accum deps a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
$c<$ :: forall accum deps a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
fmap :: forall a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
$cfmap :: forall accum deps a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
Functor
instance Monoid accum => Applicative (AccumConstructor accum deps) where
pure :: forall a. a -> AccumConstructor accum deps a
pure a
component = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ \deps
_ -> a
component
liftA2 :: forall a b c.
(a -> b -> c)
-> AccumConstructor accum deps a
-> AccumConstructor accum deps b
-> AccumConstructor accum deps c
liftA2 a -> b -> c
f (AccumConstructor (accum, deps) -> (accum, a)
u) (AccumConstructor (accum, deps) -> (accum, b)
v) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(accum, deps)
accumdeps ->
let (accum
acc1, a
component1) = (accum, deps) -> (accum, a)
u (accum, deps)
accumdeps
(accum
acc2, b
component2) = (accum, deps) -> (accum, b)
v (accum, deps)
accumdeps
in (accum
acc1 forall a. Semigroup a => a -> a -> a
<> accum
acc2, a -> b -> c
f a
component1 b
component2)
instance Monoid accum => Category (AccumConstructor accum) where
id :: forall a. AccumConstructor accum a a
id = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ forall a. a -> a
id
. :: forall b c a.
AccumConstructor accum b c
-> AccumConstructor accum a b -> AccumConstructor accum a c
(.) (AccumConstructor (accum, b) -> (accum, c)
f) (AccumConstructor (accum, a) -> (accum, b)
g) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(~(accum
accum0,a
deps0)) ->
let (accum
accum1, b
deps1) = (accum, a) -> (accum, b)
g (accum
accum0,a
deps0)
(accum
accum2, c
deps2) = (accum, b) -> (accum, c)
f (accum
accum0,b
deps1)
in (accum
accum1 forall a. Semigroup a => a -> a -> a
<> accum
accum2, c
deps2)
instance Monoid accum => Arrow (AccumConstructor accum) where
arr :: forall b c. (b -> c) -> AccumConstructor accum b c
arr = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_
first :: forall b c d.
AccumConstructor accum b c -> AccumConstructor accum (b, d) (c, d)
first (AccumConstructor (accum, b) -> (accum, c)
f) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(~(accum
accum,(b
deps,d
extra))) ->
let (accum
accum', c
component) = (accum, b) -> (accum, c)
f (accum
accum,b
deps)
in (accum
accum', (c
component, d
extra))
accumConstructor ::
forall accum deps component.
(accum -> deps -> (accum, component)) ->
AccumConstructor accum deps component
accumConstructor :: forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor accum -> deps -> (accum, component)
f = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor (\(~(accum
accum, deps
deps)) -> accum -> deps -> (accum, component)
f accum
accum deps
deps)
accumConstructor_ ::
forall accum deps component.
Monoid accum =>
(accum -> deps -> component) ->
AccumConstructor accum deps component
accumConstructor_ :: forall accum deps component.
Monoid accum =>
(accum -> deps -> component)
-> AccumConstructor accum deps component
accumConstructor_ accum -> deps -> component
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
accum deps
deps -> (forall a. Monoid a => a
mempty, accum -> deps -> component
f accum
accum deps
deps)
_accumConstructor ::
forall accum deps component.
(deps -> (accum, component)) ->
AccumConstructor accum deps component
_accumConstructor :: forall accum deps component.
(deps -> (accum, component))
-> AccumConstructor accum deps component
_accumConstructor deps -> (accum, component)
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
_ deps
deps -> deps -> (accum, component)
f deps
deps
_accumConstructor_ ::
forall accum deps component.
Monoid accum =>
(deps -> component) ->
AccumConstructor accum deps component
_accumConstructor_ :: forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ deps -> component
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
_ deps
deps -> (forall a. Monoid a => a
mempty, deps -> component
f deps
deps)
fixEnv ::
(Phased deps_, Typeable deps_, Typeable m) =>
deps_ (Constructor (deps_ Identity m)) m ->
deps_ Identity m
fixEnv :: forall (deps_ :: (* -> *) -> (* -> *) -> *) (m :: * -> *).
(Phased deps_, Typeable deps_, Typeable m) =>
deps_ (Constructor (deps_ Identity m)) m -> deps_ Identity m
fixEnv deps_ (Constructor (deps_ Identity m)) m
env = forall a. (a -> a) -> a
fix (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 (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 {b} {deps} {component}.
Coercible b (deps -> component) =>
Constructor deps component -> b
decompose deps_ (Constructor (deps_ Identity m)) m
env))
where
decompose :: Constructor deps component -> b
decompose (Constructor deps -> component
f) = coerce :: forall a b. Coercible a b => a -> b
coerce deps -> component
f
fixEnvAccum ::
(Phased deps_, Typeable deps_, Typeable m, Monoid accum, Typeable accum) =>
deps_ (AccumConstructor accum (deps_ Identity m)) m ->
(accum, deps_ Identity m)
fixEnvAccum :: forall (deps_ :: (* -> *) -> (* -> *) -> *) (m :: * -> *) accum.
(Phased deps_, Typeable deps_, Typeable m, Monoid accum,
Typeable accum) =>
deps_ (AccumConstructor accum (deps_ Identity m)) m
-> (accum, deps_ Identity m)
fixEnvAccum deps_ (AccumConstructor accum (deps_ Identity m)) m
env =
let f :: (accum, deps_ Identity m) -> (accum, deps_ Identity m)
f = 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (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 {b} {accum} {deps} {component}.
Coercible b ((accum, deps) -> (accum, component)) =>
AccumConstructor accum deps component -> b
decompose deps_ (AccumConstructor accum (deps_ Identity m)) m
env)
in forall a. (a -> a) -> a
fix (accum, deps_ Identity m) -> (accum, deps_ Identity m)
f
where
decompose :: AccumConstructor accum deps component -> b
decompose (AccumConstructor (accum, deps) -> (accum, component)
f) = coerce :: forall a b. Coercible a b => a -> b
coerce (accum, deps) -> (accum, component)
f
lmapConstructor ::
forall deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps') ->
Constructor deps' component ->
Constructor deps component
lmapConstructor :: forall deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps')
-> Constructor deps' component -> Constructor deps component
lmapConstructor TypeRep -> deps -> deps'
tweak (Constructor deps' -> component
f) =
let tyRep :: TypeRep
tyRep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @component)
in forall b c. (b -> c) -> Constructor b c
Constructor forall a b. (a -> b) -> a -> b
$ deps' -> component
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> deps -> deps'
tweak TypeRep
tyRep
lmapAccumConstructor ::
forall accum deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps') ->
AccumConstructor accum deps' component ->
AccumConstructor accum deps component
lmapAccumConstructor :: forall accum deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps')
-> AccumConstructor accum deps' component
-> AccumConstructor accum deps component
lmapAccumConstructor TypeRep -> deps -> deps'
tweak (AccumConstructor (accum, deps') -> (accum, component)
f) =
let tyRep :: TypeRep
tyRep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @component)
in forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor (\(~(accum
accum, deps
deps)) -> (accum, deps') -> (accum, component)
f (accum
accum, TypeRep -> deps -> deps'
tweak TypeRep
tyRep deps
deps))