-
-
Save rootmos/929028e52ca8e10686a6d1214dedc70b to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment