fpc-29-11-2017.hs

 
 
 
{-# LANGUAGE KindSignatures, TypeFamilies #-}
module Main where
 
import Control.Monad

newtype Identity a = Identity { runIdentity :: a }

instance Functor Identity where
  fmap f (Identity x) = Identity (f x)

instance Applicative Identity where
  pure = Identity
  Identity f <*> Identity x = Identity (f x)

instance Monad Identity where
  Identity x >>= f = f x

class MonadTrans (t :: (* -> *) -> (* -> *)) where
  lift :: Monad m => m a -> t m a

newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

instance MonadTrans (ReaderT r) where
  lift m = ReaderT $ \r -> m

instance Functor m => Functor (ReaderT r m) where
  fmap f (ReaderT rx) = ReaderT $ \r -> fmap f (rx r)

instance Applicative m => Applicative (ReaderT r m) where
  pure x = ReaderT $ \r -> pure x
  ReaderT rf <*> ReaderT rx = ReaderT $ \r -> rf r <*> rx r

instance Monad m => Monad (ReaderT r m) where
  ReaderT rx >>= f = ReaderT $ \r -> do
    x <- rx r
    runReaderT (f x) r

{-
ask :: Applicative m => ReaderT r m r
ask = ReaderT $ \r -> pure r

local :: (r -> r) -> ReaderT r m a -> ReaderT r m a
local f (ReaderT rx) = ReaderT $ \r -> rx (f r)
-}

type Reader r = ReaderT r Identity

runReader :: Reader r a -> r -> a
runReader m r = runIdentity $ runReaderT m r

testReader :: Reader Int (Int, Int, Int)
testReader = do
  x <- (+1) <$> ask
  y <- pure (+2) <*> ask
  z <- local (+3) ask
  pure (x, y, z)

newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

instance MonadTrans MaybeT where
  lift m = MaybeT (Just <$> m)

instance Functor m => Functor (MaybeT m) where
  fmap f (MaybeT m) = MaybeT (fmap (fmap f) m)

instance Applicative m => Applicative (MaybeT m) where
  pure x = MaybeT (Just <$> pure x)
  MaybeT mf <*> MaybeT mx = MaybeT (fmap (<*>) mf <*> mx)

instance Monad m => Monad (MaybeT m) where
  MaybeT mx >>= f = MaybeT $ do
    x <- mx
    case x of
      Nothing -> pure Nothing
      Just x' -> runMaybeT (f x')

{-
failM :: Monad m => MaybeT m a
failM = MaybeT (pure Nothing)
-}

testMaybeT :: Monad m => Int -> MaybeT m Int
testMaybeT x = do
  when (x < 0) failM
  (*) <$> helper1 x <*> helper2 x
 where
  helper1 x = pure (x + 1)
  helper2 x = pure (x + 2)

data Config = Config { configValue :: Int }

type AppT m = ReaderT Config (MaybeT m)
type App = AppT Identity

runAppT :: Config -> AppT m a -> m (Maybe a)
runAppT config app = runMaybeT (runReaderT app config)

runApp :: Config -> App a -> Maybe a
runApp config app = runIdentity $ runAppT config app

testApp :: App Int
testApp = do
  x <- configValue <$> ask
  when (x <= 0) $ lift failM
  pure $ x * 2

data ValidateConfig = ValidateConfig { validateConfigValue :: Int }

type ValidateT m = ReaderT ValidateConfig (AppT m)
type Validate = ValidateT Identity

runValidateT :: ValidateConfig -> ValidateT m a -> AppT m a
runValidateT c m = runReaderT m c

runValidate :: ValidateConfig -> Validate a -> App a
runValidate = runValidateT

testValidate :: Validate Int
testValidate = do
  x <- validateConfigValue <$> ask
  y <- configValue <$> lift ask
  when (x + y <= 0) $ lift (lift failM)
  pure (x + y)

type AppIO = AppT IO
type ValidateIO = ValidateT IO

runAppIO :: Config -> AppIO a -> IO (Maybe a)
runAppIO = runAppT

runValidateIO :: ValidateConfig -> ValidateIO a -> AppIO a
runValidateIO = runValidateT

testValidateIO :: ValidateIO Int
testValidateIO = do
  x <- validateConfigValue <$> ask
  y <- configValue <$> lift ask
  when (x + y <= 0) $ lift (lift failM)
  lift $ lift $ lift $ print x
  lift $ lift $ lift $ print y
  pure (x + y)

class Monad m => MonadReader m where
  type ReaderEnv m :: *
  ask :: m (ReaderEnv m)
  local
    :: (ReaderEnv m -> ReaderEnv m)
    -> m (ReaderEnv m)
    -> m (ReaderEnv m)

instance Monad m => MonadReader (ReaderT r m) where
  type ReaderEnv (ReaderT r m) = r
  ask = ReaderT $ \r -> pure r
  local f (ReaderT rx) = ReaderT $ \r -> rx (f r)

class Monad m => MonadMaybe m where
  failM :: m a

instance Monad m => MonadMaybe (MaybeT m) where
  failM = MaybeT (pure Nothing)

class Monad m => MonadIO m where
  liftIO :: IO a -> m a

instance MonadIO IO where
  liftIO = id

instance MonadIO m => MonadIO (ReaderT r m) where
  liftIO = lift . liftIO

instance MonadIO m => MonadIO (MaybeT m) where
  liftIO = lift . liftIO

instance MonadMaybe m => MonadMaybe (ReaderT r m) where
  failM = lift failM

{-
testApp :: App Int
testApp = do
  x <- configValue <$> ask
  when (x <= 0) $ lift failM
  pure $ x * 2
-}

testAppWithClass :: AppIO Int
testAppWithClass = do
  x <- configValue <$> ask
  when (x <= 0) $ failM
  liftIO $ print x
  pure $ x * 2

{-
testValidateIO :: ValidateIO Int
testValidateIO = do
  x <- validateConfigValue <$> ask
  y <- configValue <$> lift ask
  when (x + y <= 0) $ lift (lift failM)
  lift $ lift $ lift $ print x
  lift $ lift $ lift $ print y
  pure (x + y)
-}