生成带有语法约束的“inverse”解析器

Question

我最近跟进了 A Taste of Curry，然后决定通过编写一个更实质性的解析器来测试这个简单的算术解析器示例：一个原始但正确且功能强大的 HTML 解析器。

我最终得到了一个工作 node2string 函数来操作 Node（带有属性和子项），然后我 inversed 获得了一个 parse 函数，如文章中所示。

第一个天真的实现有一个错误，它解析了除了例如将琐碎的 <input/> HTML 片段精确地转换为一个 Node 表示；其他一切都不确定地产生无效的东西，比如

Node { name = "input", attrs = [Attr "type" "submit"] }
Node { name = "input type=\"submit\"", attrs = [] }

等等。

在 node2string 中进行了一些初步的天真尝试后，我意识到了这一点，我相信所有经验丰富的逻辑程序员都会立即看到这一点，即 parse = inverse node2string 对situtution 比我是：<input type="submit"/> 的上述 2 个解析结果确实正是 Node 的 2 个有效和可构造的值，这将导致 HTML 表示。

我意识到我必须限制 Node 只允许传递字母名称——虽然不是真的，但让我们保持简单——名称（当然 Attr 也是如此）。在比逻辑程序更基础的设置中（例如常规 Haskell 有更多的手写和 "instructional" 而不是纯粹的声明式编程），我会简单地将 Node 构造函数隐藏在后面例如一个 mkNode 哨兵函数，但我觉得由于推理引擎或约束求解器的工作方式，这在 Curry 中效果不佳（我在这方面可能是错的，事实上我希望我是这样）。

所以我最终得到了以下结果。我认为 Curry 元编程（或模板 Haskell，如果 Curry 支持的话）可以用于清理手动 boielrplate，但美化处理只是摆脱这种情况的一种方法。

data Name = Name [NameChar] -- newtype crashes the compiler
data NameChar = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z

name2char :: NameChar -> Char
name2char c = case c of A -> 'a'; B -> 'b'; C -> 'c'; D -> 'd'; E -> 'e'; F -> 'f'; G -> 'g'; H -> 'h'; I -> 'i'; J -> 'j'; K -> 'k'; L -> 'l'; M -> 'm'; N -> 'n'; O -> 'o'; P -> 'p'; Q -> 'q'; R -> 'r'; S -> 's'; T -> 't'; U -> 'u'; V -> 'v'; W -> 'w'; X -> 'x'; Y -> 'y'; Z -> 'z'

name2string :: Name -> String
name2string (Name s) = map name2char s

-- for "string literal" support
nameFromString :: String -> Name
nameFromString = inverse name2string

data Node = Node { nodeName :: Name, attrs :: [Attr], children :: [Node] }
data Attr = Attr { attrName :: Name, value :: String }

attr2string :: Attr -> String
attr2string (Attr name value) = name2string name ++ "=\"" ++ escape value ++ "\""
  where escape = concatMap (\c -> if c == '"' then "\\"" else [c])

node2string :: Node -> String
node2string (Node name attrs children) | null children = "<" ++ name' ++ attrs' ++ "/>"
                                       | otherwise     = "<" ++ name' ++ attrs' ++ ">" ++ children' ++ "</" ++ name' ++ ">"
  where name'     = name2string name
        attrs'    = (concatMap ((" " ++) . attr2string) attrs)
        children' = intercalate "" $ map (node2string) children

inverse :: (a -> b) -> (b -> a)
inverse f y | f x =:= y = x where x free

parse :: String -> Node
parse = inverse node2string

事实上，这非常有效（根据我的判断）：

Parser> parse "<input type=\"submit\"/>"
(Node [I,N,P,U,T] [(Attr [T,Y,P,E] "submit")] [])

Parser> parse "<input type=\"submit\" name=\"btn1\"/>"
(Node [I,N,P,U,T] [(Attr [T,Y,P,E] "submit"),(Attr [N,A,M,E] "btn1")] [])

（Curry 没有类型类所以我还不知道如何使 [NameChar] 打印得更好）

但是，我的问题是：

有没有一种方法可以使用类似 isAlpha 的方法（或者当然是更符合实际 HTML 规范的函数）来实现与此等效的结果，而无需通过NameChar 及其 "supporting members" 是冗长的样板文件？似乎无法将 "functional restriction" 放置在 ADT 中的任何位置。

在Dependently Typed Functional Logic Programming language中，我只是在类型级别表达约束，让推理引擎或约束求解器来处理，但在这里我似乎不知所措。

Answer 1

您只需使用 Char 即可获得相同的结果。正如您已经指出的那样，您可以使用 isAlpha 将 name2char 定义为部分身份。我更改了您代码的以下几行。

type NameChar = Char

name2char :: NameChar -> Char
name2char c | isAlpha c = c

这两个示例性表达式的计算如下。

test> parse "<input type=\"submit\" name=\"btn1\"/>"
(Node (Name "input") [(Attr (Name "type") "submit"),(Attr (Name "name") "btn1")] [])

test> parse "<input type=\"submit\"/>"
(Node (Name "input") [(Attr (Name "type") "submit")] [])

作为副作用，具有非字母字符的名称会自动失败并显示 nameFromString。

test> nameFromString "input "

编辑： 因为你似乎是函数模式的粉丝，你可以为 Nodes 和 Attrs 定义生成器并在你的转换函数。

attr :: Name -> String -> Attr
attr name val
  | name `elem` ["type", "src", "alt", "name"] = Attr name val

node :: String -> [Attr] -> [Node] -> Node
node name [] nodes
  |  name `elem` ["a", "p"] = Node name [] nodes
node name attrPairs@(_:_) nodes
  |  name `elem` ["img", "input"] = Node name attrPairs nodes

node2string :: Node -> String
node2string (node name attrs children)
  | null children = "<" ++ name ++ attrs' ++ "/>"
  | otherwise     = "<" ++ name ++ attrs' ++ ">"
                  ++ children' ++ "</" ++ name' ++ ">"
 where
  name'     = name
  attrs'    = concatMap ((" " ++) . attr2string) attrs
  children' = intercalate "" $ map (node2string) children

attr2string :: Attr -> String
attr2string (attr name val) = name ++ "=\"" ++ escape val ++ "\""
 where
  escape = concatMap (\c -> if c == '"' then "\\"" else [c])

这种方法有其缺点；它适用于一组特定的有效名称，但当您像以前一样使用谓词时（例如，all isAlpha name）就惨遭失败。

编辑2： 除了具有 isAlpha 条件的解决方案比您的冗长解决方案 "prettier" 相当的事实之外，它也是以声明方式定义的。没有您的评论，就不会（那么容易）清楚您正在使用 NameChar 数据类型对字母字符进行编码。另一方面，isAlpha 条件是所需属性的声明性规范的一个很好的例子。这回答了你的问题了吗？我不确定你的目的是什么。

生成带有语法约束的“inverse”解析器

Generating a parser with `inverse`, with constraints on the grammar

parsing

logic-programming

inverse

curry

functional-logic-progr