{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Registry.Lift where
import Protolude
class Applicative f => ApplyVariadic f a b where
applyVariadic :: f a -> b
instance (Applicative f, b ~ f a) => ApplyVariadic f a b where
applyVariadic = identity
instance (Applicative f, ApplyVariadic f a' b', b ~ (f a -> b')) => ApplyVariadic f (a -> a') b where
applyVariadic f fa = applyVariadic (f <*> fa)
allTo :: forall f a b. ApplyVariadic f a b => a -> b
allTo a = (applyVariadic :: f a -> b) (pure a)
class Monad f => ApplyVariadic1 f a b where
applyVariadic1 :: f a -> b
instance (Monad f, b ~ f a) => ApplyVariadic1 f (f a) b where
applyVariadic1 = join
instance (Monad f, ApplyVariadic1 f a' b', b ~ (f a -> b')) => ApplyVariadic1 f (a -> a') b where
applyVariadic1 f fa = applyVariadic1 (f <*> fa)
argsTo :: forall f a b . ApplyVariadic1 f a b => a -> b
argsTo a = (applyVariadic1 :: f a -> b) (pure a)
class Applicative f => ApplyVariadic2 f g a b where
applyVariadic2 :: (forall x . f x -> g x) -> a -> b
instance (Applicative f, b ~ g a) => ApplyVariadic2 f g (f a) b where
applyVariadic2 natfg = natfg
instance (Applicative f, ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where
applyVariadic2 natfg f a = applyVariadic2 natfg (f a)
outTo :: forall g f a b . ApplyVariadic2 f g a b => (forall x . f x -> g x) -> a -> b
outTo natfg = applyVariadic2 natfg :: a -> b