Parsing 使用免费Monad实现lexer

我正在考虑一个简单的词法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:：lexfr->lexfr->（r->r）->lexfr

…楼梯从这里开始。由于

r

预设在逆变位置，因此不可能（是吗？）为

Op

创建一个有效的

函子

实例。我想出了另一个想法，那就是对替代词法器的类型进行概括，因此

CHOICE:：LexF a->LexF a->（a->r）->LexF r

——现在它可以作为

函子来工作，尽管问题是如何将其解冻为
免费的
，就像我通常使用
liftF
：

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

我真的没有什么想法了。这当然可以推广到几乎所有其他的组合子，我只是发现
CHOICE
是一个很好的最小情况。如何应对？我很高兴听到这个例子完全被打破了，它不能像我所希望的那样在
免费的情况下工作。但因此，以这种方式编写词法分析器/解析器有意义吗？
作为处理自由单子的一般规则，您不想为“单子控制”引入原语。例如，
序列
原语是不明智的，因为自由单子本身提供了序列。同样地，
选择
原语也是不明智的，因为它应该由免费的
MonadPlus

现在，在现代版本的
free
中有一个，因为free monad transformer在列表基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
组合符，则可以使用transformer magic通过列表基单子定义它们：

fail :: Lex a
fail = empty

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

然后你可以：

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

{-#语言派生函子#-}
{-#语言独立派生}
{-#语言GADTs}
{-#选项#GHC-墙#-}
进口控制单体状态
导入控制
进口管制。单体。无反式
数据LexF r在哪里
POP:：（字符->r）->LexF r
PEEK:：（Char->r）->LexF r
派生实例函子LexF
类型Lex=FreeT LexF[]
pop:：（字符->a）->Lex a
pop f=liftF$pop f
偷看：：（字符->a）->Lex a
peek f=liftF$peek f
anyChar:：Lex Char
anyChar=pop id
char:：char->Lex char
char c=do
c'分析器a
runLex=iterTM go
where go:：LexF（解析器a）->解析器a
go（POP f）=StateT POP'>>=f
其中pop'（c:cs）=[（c，cs）]
pop'.=[]
go（PEEK f）=StateT PEEK'>>=f
其中peek'（c:cs）=[（c，c:cs）]
peek'.=[]
解析：：lexa->String->[（a，String）]
parse=runStateT。伦莱克斯
main:：IO（）
main=do
让测试=解析a_或b
打印$test“abc”
打印$test“bca”
打印$test“cde”

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