How to implement Monad, MonadError and MonadState for a monadic parser without GeneralizedNewTypederiving extension?

Question

I found a Parser example in haskell that use monadic error handling and state. It's written like this.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad.Except
import Control.Monad.State

newtype Parser a
  = Parser { runParser :: ExceptT String (State String) a }
    deriving ( Functor
             , Applicative
             , Monad
             , MonadError String
             , MonadState String
             )

I understand what it does and how to use it. But, what I want to know is how it's implemented without GeneralizedNewtypeDeriving extension.

So, how to make Parser an instance of Functor , Applicative , Monad , MonadError , MonadState if there is no GeneralizedNewtypeDeriving extension?

Answer 1

GeneralizedNewtypeDeriving wraps the instances of the underlying type (in your case, ExceptT String (State String) ) with the newtype boilerplate. The Functor one, for example, amounts to:

-- p :: ExceptT String (State String) a
instance Functor Parser where
    fmap f (Parser p) = Parser (fmap f p)
    -- Or, equivalently:
    -- fmap f = Parser . fmap f . runParser

As for what the underlying instances do, you can check their sources by following the "Source" links for the instances in the docs. Functor for ExceptT , for example, is:

instance (Functor m) => Functor (ExceptT e m) where
    fmap f = ExceptT . fmap (fmap f) . runExceptT

(The nested fmap s are there because the underlying type of ExceptT ema is m (Either ea) , and so there are two Functor layers to get through: m and Either .)

Answer 2

It took me almost the whole day to figure out how implement this. But, after I figure it out, the concept is actually pretty simple. The whole point is to dig through the monad stack to apply a function that is to be implemented and then bury the result in the monad stack again. Those jobs can be done with these functions:

unwrap :: Parser a -> String -> (Either String a, String)
unwrap p s = runState (runExceptT (runParser p)) s

wrap :: (String -> (Either String a, String)) -> Parser a
wrap f = Parser (ExceptT (state (\s -> (f s))))

So, to make the Parser an instance of Functor , Applicative , Monad , MonadError and MonadState I can just define a lambda or a function inside where binding and then wrap it with wrap .

Here is the instances implementation:

instance Functor Parser where
  fmap f p = wrap fn
    where fn s = let (ea, s') = unwrap p s
                  in case ea of
                       Right a -> (Right (f a), s')
                       Left  e -> (Left e, s)

instance Applicative Parser where
  pure x    = wrap fn
    where fn s = (Right x, s)

  p1 <*> p2 = wrap fn
    where fn s = let (ef, s')  = unwrap p1 s
                     (ea, s'') = unwrap p2 s'
                  in run ef ea s'' s

          run (Right f) (Right a) s' s = (Right (f a), s')
          run (Left  e) _         s' s = (Left e, s)
          run _         (Left e)  s' s = (Left e, s)

instance Monad Parser where
  return  = pure

  p >>= f = wrap fn
    where fn s = let (ea, s') = unwrap p s
                  in case ea of
                       Right a -> unwrap (f a) s'
                       Left  e -> (Left e, s)

instance MonadError String Parser where
  throwError err = wrap fn
    where fn s = (Left err, s)

  catchError p h = wrap fn
    where fn s = let (ea, s') = unwrap p s
                  in case ea of
                       Right a -> (Right a, s')
                       Left  e -> unwrap (h e) s

instance MonadState String Parser where
  get   = wrap fn
    where fn s = (Right s, s)

  put s = wrap fn
    where fn s = (Right (), s)

With that, the parser now can be used like this:

item :: Parser Char
item = do
  s <- get
  case s of
    []     -> throwError "unexpected end of input"
    (c:cs) -> do put cs
                 return c

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = item >>= \c -> if p c then return c else throwError $ "unexpected: " ++ show c

char :: Char -> Parser Char
char c = satisfy (c ==)

main :: IO ()
main = do
  print $ unwrap item "c"
  print $ unwrap (char 'c') "c"
  print $ unwrap (satisfy isDigit) "c"