Configured.hs

module Control.Joint.Base.Configured where

import Control.Joint.Composition (Composition (Primary, run))
import Control.Joint.Transformer (Transformer (Schema, embed, build, unite))
import Control.Joint.Modulator (Modulator ((-<$>-)))
import Control.Joint.Schemes.TU (TU (TU))

newtype Configured e a = Configured (e -> a)

instance Functor u => Functor (TU ((->) e) u) where
	fmap f (TU x) = TU $ \r -> f <$> x r

instance Applicative u => Applicative (TU ((->) e) u) where
	pure = TU . pure . pure
	TU f <*> TU x = TU $ \r -> f r <*> x r

instance (Applicative u, Monad u) => Monad (TU ((->) e) u) where
	TU x >>= f = TU $ \e -> x e >>= ($ e) . run . f

instance Composition (Configured e) where
	type Primary (Configured e) a = (->) e a
	run (Configured x) = x

instance Transformer (Configured e) where
	type Schema (Configured e) u = TU ((->) e) u
	embed x = TU . const $ x
	build x = TU $ pure <$> run x
	unite = TU

instance Modulator (Configured e) where
	f -<$>- (TU x) = TU $ f <$> x

ask :: Configured e e
ask = Configured $ \e -> e