WithoutLift.hs

{-# LANGUAGE TypeOperators, Rank2Types, GeneralizedNewtypeDeriving, GADTs #-}
module WithoutLift where

import Control.Natural
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Free

class Interface m where
    suchFunction :: Int -> m Int

class MonadIO m => BaseMonad m where
    baseOutput :: String -> m ()
    baseOutput = liftIO . putStrLn

instance BaseMonad IO where


newtype Dispatch = MkDispatch (forall m . BaseMonad m => Concretization m)

data Concretization m = forall n . (Interface n, BaseMonad n)
  => MkConcretization (n ~> m)



newtype Concrete1 m a = MkConcrete1 { runConcrete1 :: ReaderT Int m a }
    deriving (Monad, Applicative, Functor, MonadReader Int)

instance Monad m => Interface (Concrete1 m) where
    suchFunction i = do
        x <- ask
        return $ x + i

instance MonadIO m => MonadIO (Concrete1 m) where
    liftIO = MkConcrete1 . liftIO

instance BaseMonad m => BaseMonad (Concrete1 m) where

dispatch1 :: Int -> Dispatch
dispatch1 i = MkDispatch $
    MkConcretization ((flip runReaderT) i . runConcrete1)



newtype Concrete2 m a = MkConcrete2 { runConcrete2 :: StateT Int m a }
    deriving (Monad, Applicative, Functor, MonadState Int)

instance Monad m => Interface (Concrete2 m) where
    suchFunction i = do
        x <- get
        put $ x * i
        return $ x * i

instance MonadIO m => MonadIO (Concrete2 m) where
    liftIO = MkConcrete2 . liftIO

instance BaseMonad m => BaseMonad (Concrete2 m) where

dispatch2 :: Int -> Dispatch
dispatch2 i = MkDispatch $
    MkConcretization ((flip evalStateT) i . runConcrete2)


data Concrete3F m v where
    SomeFunctionF :: Int -> (Int -> v) -> Concrete3F m v
    LiftF :: forall a m v . (m a) -> (a -> v) -> Concrete3F m v

instance Functor (Concrete3F m) where
    fmap f (SomeFunctionF i k) = SomeFunctionF i (f . k)
    fmap f (LiftF ma k) = LiftF ma (f . k)

newtype Concrete3 m a = MkConcrete3 { runConcrete3 :: Free (Concrete3F m) a }
    deriving (Monad, Applicative, Functor)

instance Interface (Concrete3 m) where
    suchFunction i = MkConcrete3 . liftF $ SomeFunctionF i id

instance MonadIO m => MonadIO (Concrete3 m) where
    liftIO io = MkConcrete3 . liftF $ LiftF (liftIO io) id

instance BaseMonad m => BaseMonad (Concrete3 m) where
    baseOutput s = MkConcrete3 . liftF $ LiftF (baseOutput s) id

dispatch3 :: Dispatch
dispatch3 = MkDispatch $ MkConcretization (iterM go . runConcrete3)

go :: BaseMonad m => Concrete3F m (m v) -> m v
go (SomeFunctionF i k) = k (i * i)
go (LiftF ma k) = ma >>= k


program1 :: (Interface n, BaseMonad n) => n Int
program1 = do
    i <- suchFunction 1
    baseOutput $ "Interface: program1 " ++ show i
    return i

program2 :: BaseMonad m => Int -> m ()
program2 i = do
    baseOutput $ "BaseMonad: program2 " ++ show i

program3 :: BaseMonad m => Dispatch -> m ()
program3 (MkDispatch (MkConcretization evalI)) = do
    l <- evalI $ do
        i <- suchFunction 2
        j <- program1
        let k = i + j
        program2 k
        return $ k
    baseOutput $ "BaseMonad again l=" ++ show l


main :: IO ()
main = do
    putStrLn "dispatch1 7"
    let d1 = dispatch1 7
    program3 d1

    putStrLn "dispatch2 7"
    let d2 = dispatch2 7
    program3 d2

    putStrLn "dispatch3"
    program3 dispatch3