An exploration of Monad Transformers in Haskell

transformers.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Transformers where

import Control.Applicative
import Control.Monad
import qualified Data.Char as Char

first :: (a -> c) -> (a, b) -> (c, b)
first f (a, b) = (f a, b)

-- Identity

newtype Identity a = Identity { runIdentity :: a }

instance Functor Identity where
  fmap f = Identity . f . runIdentity

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

instance Monad Identity where
  a >>= f = f . runIdentity $ a

-- StateT

newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }

instance (Functor m) => Functor (StateT s m) where
  fmap f a = StateT $ fmap (first f) . runStateT a

instance (Monad m) => Applicative (StateT s m) where
  pure a  = StateT $ \s -> pure (a, s)
  f <*> a = StateT $ \s -> do
    (f', s')  <- runStateT f s
    (a', s'') <- runStateT a s'
    return (f' a', s'')

instance (Monad m) => Monad (StateT s m) where
  a >>= f = StateT $ \s -> do
    (a', s') <- runStateT a s
    runStateT (f a') s'

instance (Alternative m, Monad m) => Alternative (StateT s m) where
  empty   = StateT . const $ empty
  a <|> b = StateT $ \s -> runStateT a s <|> runStateT b s

-- MonadState

class (Monad m) => MonadState s m where
  get :: m s
  put :: s -> m ()

instance (Monad m) => MonadState s (StateT s m) where
  get   = StateT $ \s -> pure (s, s)
  put s = StateT . const . pure $ ((), s)

-- MaybeT

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

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

instance (Applicative m) => Applicative (MaybeT m) where
  pure    = MaybeT . pure . Just
  f <*> a = MaybeT $ (<*>) <$> runMaybeT f <*> runMaybeT a

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

instance (Monad m) => Alternative (MaybeT m) where
  empty   = MaybeT . pure $ Nothing
  a <|> b = MaybeT $ (<|>) <$> runMaybeT a <*> runMaybeT b

-- ParserT

newtype ParserT i m o = ParserT { runParserT :: StateT i (MaybeT m) o }
                        deriving ( Functor
                                 , Applicative
                                 , Monad
                                 , Alternative
                                 , MonadState i
                                 )

runParser :: ParserT i m o -> i -> m (Maybe (o, i))
runParser p i = runMaybeT . flip runStateT i . runParserT $ p

-- parsers

predParser :: Monad m => (a -> Bool) -> ParserT [a] m a
predParser p = do
  input <- get
  case input of
    (x : xs) | p x -> put xs >> return x
    _              -> empty

charParser :: Monad m => Char -> ParserT String m Char
charParser c = predParser (== c)

spacesParser :: Monad m => ParserT String m String
spacesParser = many $ predParser Char.isSpace

notSpacesParser :: Monad m => ParserT String m String
notSpacesParser = some $ predParser (not . Char.isSpace)

wordsParser :: Monad m => ParserT String m [String]
wordsParser = many $ spacesParser *> notSpacesParser <* spacesParser

main :: IO ()
main = do
  input  <- getLine
  parsed <- runParser wordsParser input
  case parsed of
    Nothing      -> putStrLn "NO PARSE"
    Just (ws, _) -> forM_ ws putStrLn