-
-
Save rootmos/1b413f619a651e618d8c4b15ae3c1f8a 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 WithLift 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, Monad n) | |
=> MkConcretization (n ~> m) (m ~> n) | |
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 | |
dispatch1 :: Int -> Dispatch | |
dispatch1 i = MkDispatch $ | |
MkConcretization ((flip runReaderT) i . runConcrete1) (MkConcrete1 . lift) | |
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 | |
dispatch2 :: Int -> Dispatch | |
dispatch2 i = MkDispatch $ | |
MkConcretization ((flip evalStateT) i . runConcrete2) (MkConcrete2 . lift) | |
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 | |
dispatch3 :: Dispatch | |
dispatch3 = MkDispatch $ MkConcretization | |
(iterM go . runConcrete3) | |
(MkConcrete3 . liftF . \ma -> LiftF ma id) | |
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, Monad n, BaseMonad m) => (m ~> n) -> n Int | |
program1 liftB = do | |
i <- suchFunction 1 | |
liftB $ 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 liftB)) = do | |
l <- evalI $ do | |
i <- suchFunction 2 | |
j <- program1 liftB | |
let k = i + j | |
liftB $ 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