Lifting applicative compositions to bigger compositions

ComposeLift1.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |  When working with deeply nested functor compostions (see "Stack" in this file) sometimes I want to lift an action with a subset
-- of the effects into an action with all effects. Doing it manually is tedious.
--
-- This is an experiment in automatig that lifting using a "Lifty" typeclass.
--
-- Required packages:
-- "managed"
-- "aeson"
-- "transformers"
module Main where


import Control.Arrow (Kleisli (..))
import Control.Monad.Managed
import Control.Monad.Trans.Reader
import Data.Aeson
import Data.Aeson.Types
import Data.Functor.Compose
import Data.Kind
import Data.Proxy

--
-- THE MACHINERY
--

data Inspection = BothTerminal | TerminalMatchesOuter | TerminalMatchesInner | ComposeMatchesOuter | ComposeDoesNotMatchOuter

-- lifts a composition of functors n to "more general" compositon of functors f
type Lifty :: (Type -> Type) -> (Type -> Type) -> Constraint
class Lifty f n where
  lifty :: n x -> f x

-- this type family, along with a LiftyAux class, is a workaround to avoid OverlappingInstances.
type Inspect :: (Type -> Type) -> (Type -> Type) -> Inspection
type family Inspect f g where
  Inspect f f = BothTerminal
  Inspect (Compose f _) f = TerminalMatchesOuter
  Inspect (Compose _ g) g = TerminalMatchesInner
  Inspect (Compose f _) (Compose f _) = ComposeMatchesOuter
  Inspect (Compose _ _) _ = ComposeDoesNotMatchOuter

type LiftyAux :: Inspection -> (Type -> Type) -> (Type -> Type) -> Constraint
class LiftyAux inspection f n where
  liftyAux :: Proxy inspection -> n x -> f x

-- delegate into LiftyAux
instance LiftyAux (Inspect f n) f n => Lifty f n where
  lifty x = liftyAux (Proxy @(Inspect f n)) x

instance LiftyAux BothTerminal f f where
  liftyAux _ x = x

instance (Applicative f, Applicative g) => LiftyAux TerminalMatchesOuter (Compose f g) f where
  liftyAux _ x = Compose $ fmap pure $ x

instance (Applicative f, Applicative g) => LiftyAux TerminalMatchesInner (Compose f g) g where
  liftyAux _ x = Compose $ pure $ x

instance (Applicative f, Applicative u, Lifty u v) => LiftyAux ComposeMatchesOuter (Compose f u) (Compose f v) where
  liftyAux _ (Compose x) = Compose $ fmap lifty $ x

instance (Applicative f, Applicative u, Applicative y, Lifty u y) => LiftyAux ComposeDoesNotMatchOuter (Compose f u) y where
  liftyAux _ x = Compose $ pure $ lifty $ x

--
-- THE EXAMPLE
--

-- Each Applicative layer is a "stage" that must be peeled in order to get to the "a":
-- - parsing some configuration file
-- - allocating some resource required by the value
-- - reading some environment, possibly carrying some capability
type Stack a = (Kleisli Parser Value `Compose` Managed `Compose` Reader Env) a

data Env = Env -- some random environment for Reader

-- just read the env
foo :: Reader Env (String -> IO ())
foo = undefined

-- just allocate resources
bar :: Managed (String -> IO ())
bar = undefined

-- just parse the conf
bir :: Kleisli Parser Value (String -> IO ())
bir = undefined

-- Missing the Reader
boz :: (Kleisli Parser Value `Compose` Managed) (String -> IO ())
boz = undefined

-- Missing the Managed
baz :: (Kleisli Parser Value `Compose` Reader Env) (String -> IO ())
baz = undefined

-- Missing the Parser
woo :: (Managed `Compose` Reader Env) (String -> IO ())
woo = undefined

-- The full composition type
xee :: Stack (String -> IO ())
xee = undefined

fooLifted, barLifted, birLifted, bozLifted, bazLifted, wooLifted, xeeLifted :: Stack (String -> IO ())
fooLifted = lifty foo
barLifted = lifty bar
birLifted = lifty bir
bozLifted = lifty boz
bazLifted = lifty baz
wooLifted = lifty woo
xeeLifted = lifty xee

main :: IO ()
main = return ()