{-# 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.Env hiding (AccumConstructor, Constructor, accumConstructor, constructor, fixEnv, fixEnvAccum)
import Control.Category (Category)
import Control.Category qualified
import Control.Arrow
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))