使用 Free Monad 实现词法分析器

问题描述

我正在考虑 free monad 的一个用例，它是一个简单的词法 DSL。到目前为止，我想出了一些原始操作：

data LexF r where
  POP  :: (Char -> r) -> LexF r
  PEEK :: (Char -> r) -> LexF r
  FAIL :: LexF r
  ...

instance Functor LexF where
  ...

type Lex = Free LexF

我遇到的问题是我想要一个 CHOICE 原语来描述尝试执行一个解析器并在失败时回退到另一个解析器的操作。类似CHOICE :: LexF r -> LexF r -> (r -> r) -> LexF r...

...这里开始楼梯。由于 r 预设在逆变位置，因此不可能（是吗？）为 Functor 创建有效的 Op 实例。我想出了一些其他想法，即对替代词法分析器的类型进行概括，所以 CHOICE :: LexF a -> LexF a -> (a -> r) -> LexF r – 现在它可以作为 Functor 工作，尽管问题在于将其解冻为 Free ，就像我通常用 liftF:

choice :: OpF a -> OpF a -> OpF a
choice c1 c2 = liftF $ CHOICE _ _ id  -- how to fill the holes :: Op a ?

我真的没有任何想法了。这当然可以推广到几乎所有其他组合器，我只是发现 CHOICE 是一个很好的最小案例。如何解决？我很高兴听到这个例子完全被破坏了，它不能像我想的那样与 Free 一起工作。但因此，以这种方式编写词法分析器/解析器是否有意义？

解决方法

作为使用自由 monad 时的一般规则，您不想为“monadic 控制”引入原语。例如，SEQUENCE 原语是不明智的，因为自由 monad 本身提供了排序。同样，CHOICE 原语也是不明智的，因为它应该由免费的 MonadPlus。

现在，free 的现代版本中有 no free MonadPlus，因为等效的功能由基于列表 monad 的免费 monad 转换器提供，即 FreeT f []。所以，你可能想要的是定义：

data LexF r where
  POP  :: (Char -> r) -> LexF r
  PEEK :: (Char -> r) -> LexF r
deriving instance Functor LexF
type Lex = FreeT LexF []

pop :: (Char -> a) -> Lex a
pop f = liftF $ POP f

peek :: (Char -> a) -> Lex a
peek f = liftF $ PEEK f

但没有 FAIL 或 CHOICE 原语。

如果您要定义 fail 和 choice 组合子，它们将通过使用变换器魔术的列表基 monad 来定义：

fail :: Lex a
fail = empty

choice :: Lex a -> Lex a -> Lex a
choice = (<|>)

虽然没有真正的理由来定义这些。

SPOILERS 跟随...无论如何，您现在可以编写如下内容：

anyChar :: Lex Char
anyChar = pop id

char :: Char -> Lex Char
char c = do
  c' <- anyChar
  guard $ c == c'
  return c'

a_or_b :: Lex Char
a_or_b = char 'a' <|> char 'b'

为您的 monad 原语提供解释器，在这种情况下将它们解释为 StateT String [] AKA String -> [(a,String)] monad：

type Parser = StateT String []
runLex :: Lex a -> Parser a
runLex = iterTM go
  where go :: LexF (Parser a) -> Parser a
        go (POP f) = StateT pop' >>= f
          where pop' (c:cs) = [(c,cs)]
                pop' _      = []
        go (PEEK f) = StateT peek' >>= f
          where peek' (c:cs) = [(c,c:cs)]
                peek' _      = []
parse :: Lex a -> String -> [(a,String)]
parse = runStateT . runLex

然后你可以：

main :: IO ()
main = do
  let test = parse a_or_b
  print $ test "abc"
  print $ test "bca"
  print $ test "cde"

完整示例：

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall #-}

import Control.Monad.State
import Control.Applicative
import Control.Monad.Trans.Free

data LexF r where
  POP  :: (Char -> r) -> LexF r
  PEEK :: (Char -> r) -> LexF r
deriving instance Functor LexF
type Lex = FreeT LexF []

pop :: (Char -> a) -> Lex a
pop f = liftF $ POP f

peek :: (Char -> a) -> Lex a
peek f = liftF $ PEEK f

anyChar :: Lex Char
anyChar = pop id

char :: Char -> Lex Char
char c = do
  c' <- anyChar
  guard $ c == c'
  return c'

a_or_b :: Lex Char
a_or_b = char 'a' <|> char 'b'

type Parser = StateT String []
runLex :: Lex a -> Parser a
runLex = iterTM go
  where go :: LexF (Parser a) -> Parser a
        go (POP f) = StateT pop' >>= f
          where pop' (c:cs) = [(c,String)]
parse = runStateT . runLex

main :: IO ()
main = do
  let test = parse a_or_b
  print $ test "abc"
  print $ test "bca"
  print $ test "cde"