Skip to content

Instantly share code, notes, and snippets.

@rootmos
Created Aug 27, 2017
Embed
What would you like to do?
{-# 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