This is short gist about problem I run today into, and its solution. It feels that probably I'm over engineering stuff, so: please comment!

existential-constraint.hs

#!/usr/bin/env stack
-- stack --resolver=lts-6.0 runghc --package constraints --package mtl --package lens --package text --package time
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds, UndecidableInstances, ScopedTypeVariables, InstanceSigs, OverloadedStrings, TemplateHaskell #-}

-- This is short gist about problem I run today into,
-- and its solution. It feels that probably I'm over engineering stuff,
-- so: please comment!

import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Data.Constraint
import Data.Proxy (Proxy (..))
import Data.Foldable (traverse_)
import Data.Functor.Identity
import Data.Text
import Data.Time
import GHC.TypeLits (Symbol)

-- Suppose we have a types we want to render, rendering happens in a monad
class Renderable' a where
    render' :: Monad m => a -> m [String]

instance Renderable' () where
    render' _ = return ["unit"]

-- Yet some types would need a bit more then just a monad,
-- for example some additional information like current date time!
class Renderable a where
    type RenderableC a (m :: * -> *) :: Constraint
    type RenderableC a m = ()

    render :: (Monad m, RenderableC a m) => a -> m [String]

instance Renderable () where
    render _ = return ["unit"]

newtype Created = Created UTCTime

instance Renderable Created where
    type RenderableC Created m = MonadReader UTCTime m
    
    render (Created x) = do
        now <- ask
        return ["Created " ++ show (diffUTCTime now x) ++ " ago"]

-- >>> createdExample
-- ["Created 0.00001s ago"]
createdExample :: IO ()
createdExample = do
    cre <- getCurrentTime
    now <- getCurrentTime

    -- Using (->) UTCTime as MonadReader
    print $ render (Created cre) now


-- And constraints compose!
instance (Renderable a, Renderable b) => Renderable (a, b) where
    type RenderableC (a, b) m = (RenderableC a m, RenderableC b m)
    render (a, b) = (++) <$> render a <*> render b

instance (Renderable a) => Renderable [a] where
    type RenderableC [a] m = RenderableC a m
    render = fmap mconcat . traverse render 

-- >>> createdExample2
-- ["Created 0.000002ss ago","unit"]
createdExample2 :: IO ()
createdExample2 = do
    cre <- getCurrentTime
    now <- getCurrentTime

    -- Using (->) UTCTime as MonadReader
    print $ render (Created cre, ()) now


-- But MonadReader constraints don't compose that well, we cannot have e.g.
-- '(MonadReader UTCTime m, MonadReader Text m)' constraint.

-- We can use optics approach, by requiring specific pieces of reader environment:

class HasUTCTime env where
    utcTime :: Lens' env UTCTime

instance HasUTCTime UTCTime where
    utcTime = id

class HasText env where
    text :: Lens' env Text

instance HasText Text where
    text = id

-- Yet the problem is that we cannot use these as it in 'Renderable'

newtype C = C UTCTime
data T = T

-- @
--instance Renderable C where
--    type RenderableC C m = (MonadReader env m, HasUTCTime m)
--    render = undefined
-- @
--
-- fails with:
--
-- @
-- Not in scope: type variable ‘env’
-- @
--
-- We'd need some kind of existential constraints!

-- One solution would look like:

-- Non dependent class
class MonadReader' c m where
    monadReaderConstraint :: MRE c m

data MRE c m where
    MkMRE :: Dict (MonadReader env m, c env) -> MRE c m

--  We can even have generic constraint, because 'env' is determined by 'm' thru 
--  'MonadReader':
instance (MonadReader env m, c env) => MonadReader' c m where
    monadReaderConstraint = MkMRE Dict

-- Let's try!

instance Renderable C where
    type RenderableC C m = MonadReader' HasUTCTime m

    render :: forall m. (Monad m, RenderableC C m) => C -> m [String]
    render (C x) = case monadReaderConstraint :: MRE HasUTCTime m of
        MkMRE Dict -> do
            now <- view utcTime
            return ["Created " ++ show (diffUTCTime now x) ++ " ago"]
            
instance Renderable T where
    type RenderableC T m = MonadReader' HasText m
  
    render :: forall m. (Monad m, RenderableC T m) => T -> m [String]
    render T = case monadReaderConstraint :: MRE HasText m of
        MkMRE Dict -> do
            t <- view text
            return [unpack t]


data Env = Env { _envUTCTime :: UTCTime, _envText :: Text }
makeLenses ''Env

instance HasUTCTime Env where
    utcTime = envUTCTime

instance HasText Env where
    text = envText

-- | and final example:
--
-- >>> example
-- "unit"
-- "foobar"
-- "Created 0.000001s ago"
example :: IO ()
example = do
    c <- getCurrentTime
    now <- getCurrentTime
    let env = Env now "foobar"
    let out = render ((), (T, C c)) env :: [String] 
    traverse_ print out

main :: IO ()
main = do
    createdExample
    createdExample2
    example

-------------------------------------------------------------------------------
-- Follow-up: 
-------------------------------------------------------------------------------

-- Renderable is then wrapped in a named container, which knows how to render
-- itself in any environment.
--
-- I could get away with newtypes, but as they all have the same structure: I
-- tag them with type level string, and can treat them uniformly.  In other
-- words instead of writing 'Renderable' instance directly, I write
-- 'RenderableStuff'. 
--
-- Yet there are other classes I want for 'Stuff', now I can write them once.
-- With newtype approach I'd need to write them, even I could autoderive them,
-- I'd need to remember to do that.
--
-- However: Whatever approach I chose here, I still would have problem with
-- existential type-classes.
data Stuff (sym :: Symbol) a b = Stuff a b

class Renderable b => RenderableStuff (sym :: Symbol) a b | sym -> a, sym -> b where
    renderStuff :: Proxy sym -> a -> b -> [String] 

instance RenderableStuff sym a b => Renderable (Stuff sym a b) where
    render (Stuff a b) = return $ renderStuff (Proxy :: Proxy sym) a b

-- We can define helpers for simple Stuff
renderStuffInReader
    :: (Renderable b, RenderableC b ((->) a))
    => a -> b -> [String]
renderStuffInReader a b =
    render b a

renderStuffInReaderWithState
    :: (Renderable b, RenderableC b (StateT s ((->) a)))
    => s -> a -> b -> [String]
renderStuffInReaderWithState s a b = evalStateT (render b) s a

-- -------------------------------------------------------------------------------
-- Bigger example:
-------------------------------------------------------------------------------

data X = X

class HasInt env where
    int :: Lens' env Int

instance HasInt Int where
    int = id

instance Renderable X where
    type RenderableC X m = MonadState' HasInt m

    render :: forall m. (Monad m, RenderableC X m) => X -> m [String]
    render X = case monadStateConstraint :: MSE HasInt m of
        MkMSE Dict -> do
            i <- int <+= 1
            return ["X: " ++ show i]

type Weird = (((), [X]), (T, C))
type ExampleStuff = Stuff "weird" Env Weird

instance RenderableStuff "weird" Env Weird where
    renderStuff _ = renderStuffInReaderWithState (0 :: Int)

-- |
-- @
-- >>> exampleStuff
-- "unit"
-- "X: 1"
-- "X: 2"
-- "X: 3"
-- "X: 4"
-- "foobar"
-- "Created 0.000001s ago"
-- @
exampleStuff :: IO ()
exampleStuff = do
    c <- getCurrentTime
    now <- getCurrentTime
    let env = Env now "foobar"
    let weird = (((), [X, X, X, X]), (T, C c)) :: Weird
    let stuff = Stuff env weird :: ExampleStuff
    let out = runIdentity $ render stuff :: [String]
    traverse_ print out

-------------------------------------------------------------------------------
-- MonadState'
-------------------------------------------------------------------------------

class MonadState' c m where
    monadStateConstraint :: MSE c m

data MSE c m where
    MkMSE :: Dict (MonadState s m, c s) -> MSE c m

instance (MonadState s m, c s) => MonadState' c m where
    monadStateConstraint = MkMSE Dict