如何在没有GeneralizedNewTypederiving扩展的情况下为Monadic解析器实现Monad，MonadError和MonadState？

Question

我在haskell中找到了一个解析器示例，该示例使用单子错误处理和状态。 它是这样写的。

{-# 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
             )

我了解它的作用以及使用方法。 但是，我想知道的是在没有GeneralizedNewtypeDeriving扩展的情况下如何实现它。

那么，如果没有GeneralizedNewtypeDeriving扩展，如何使Parser成为Functor ， Applicative ， Monad ， MonadError ， MonadState的实例？

Answer 1

GeneralizedNewtypeDeriving包装的基本类型的实例（在你的情况， ExceptT String (State String) ）与newtype样板。 例如，一个Functor等于：

-- 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

至于基础实例的功能，您可以通过单击文档中实例的“源”链接来检查其源。 例如， ExceptT Functor是：

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

（之所以有嵌套的fmap是因为ExceptT ema的基础类型是m (Either ea) ExceptT ema m (Either ea) ，所以有两个Functor层可以通过： m和Either 。）

Answer 2

我花了整整一天的时间来弄清楚如何实现这一目标。 但是，在我弄清楚之后，这个概念实际上非常简单。 重点是深入研究monad堆栈以应用要实现的功能，然后将结果再次埋入monad堆栈中。 这些工作可以通过以下功能完成：

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))))

因此，要使解析器成为Functor ， Applicative ， Monad ， MonadError和MonadState的实例，我可以where绑定的内部定义一个lambda或函数，然后用wrap对其进行wrap 。

这是实例实现：

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)

这样，解析器现在可以像这样使用：

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"