如何拥有具有一组已知字符串文字的总和类型 (ADT)?

Question

是否可以本着以下精神编写代码：

data EventTable = "table1" | "table2" | "some_other_table"
case eventTable of 
"table1" -> -- do something
"table2" -> -- do something else
"some_other_table" -> -- do something else
"unknown_table"-> -- SHOULD NOT COMPILE

我正在尝试直接使用远程 API 提供的字符串文字，而不是首先将它们映射到常规的 Haskell sum-type/ADT，并且必须为其编写序列化和反序列化函数。

Answer 1

Haskell没有像TypeScript的字符串文字类型(这是单例类型：TypeScript只允许你使用给定的字符串，如果它可以知道你已经检查了字符串确实适合该类型)，最好的方法可能是手动滚动常规数据类型和简单的智能构造函数。但正如@chi在评论中指出的那样，如果你有很多字符串要处理，这可能是代码生成的工作。

我们将编写一个模板 Haskell 助手来像

stringLitTy "Foo" ["bar", "baz"]

转换为data声明、智能构造函数和toString函数：

data Foo = Bar | Baz deriving (Eq, Ord, Bounded, Enum, Show, Read)
mkFoo :: String -> Maybe Foo
mkFoo "bar" = Just Bar
mkFoo "baz" = Just Baz
mkFoo _ = Nothing
fooToString :: Foo -> String
fooToString Bar = "bar"
fooToString Baz = "baz"

执行此操作的代码非常简单，因此，如果您不熟悉TH，这将是一个很好的速成课程。

首先，让我们为类型和函数创建一些名称，以及从字符串文本到一些构造函数名称的映射。

{-# LANGUAGE TemplateHaskell #-}
module StringLit where
import Data.Char
import Language.Haskell.TH
legaliseCon :: String -> String
legaliseCon (x:xs) = toUpper x : map (c -> if not (isAlphaNum c) then '_' else c) xs
legaliseFun :: String -> String
legaliseFun (x:xs) = toLower x : map (c -> if not (isAlphaNum c) then '_' else c) xs
stringLitTy :: String -> [String] -> Q [Dec]
stringLitTy typeName strs =
let tyName = mkName $ legaliseCon typeName
constrName = mkName $ legaliseFun ("mk" ++ typeName)
toStringName = mkName $ legaliseFun (typeName ++ "ToString")
conNames = [(n, mkName $ legaliseCon n) | n <- strs]
in sequenceA [
mkDataDecl tyName (map snd conNames),
mkConstrDecl constrName conNames,
mkToStringDecl toStringName conNames
]

legaliseCon和legaliseFun是将字符串转换为对构造函数或函数有效的形式的钝器。(那里肯定有改进的余地！stringLitTy调用下面的mkDataDecl、mkConstrDecl和mkToStringDecl来生成顶级声明。它们都非常简单：mkDataDecl调用dataD来构造具有适当deriving子句的数据类型声明。

enumClasses = sequenceA [
[t| Eq |],
[t| Ord |],
[t| Bounded |],
[t| Enum |],
[t| Show |],
[t| Read |]
]
mkDataDecl :: Name -> [Name] -> Q Dec
mkDataDecl tyName conNames =
dataD
(return [])                     -- datatype context
tyName                          -- name
[]                              -- type parameters
Nothing                         -- kind annotation
[normalC n [] | n <- conNames]  -- constructors, none of which have any parameters
enumClasses                     -- "deriving" classes

mkConstrDecl使用funD根据从字符串到生成的构造函数名称的映射，为智能构造函数(mkFoo)生成代码。

mkConstrDecl :: Name -> [(String, Name)] -> Q Dec
mkConstrDecl name map = funD name $ [
clause
[litP $ stringL str]                          -- the string literal pattern on the LHS
(normalB $ appE [| Just |] (conE con))        -- Just Con on the RHS
[]                                            -- where clauses
| (str, con) <- map]
++ [clause [wildP] (normalB $ [| Nothing |]) []]  -- mkFoo _ = Nothing

mkToStringDecl做的大致相同，只是构造函数在左侧，字符串文字在右侧。并且需要通配符子句或Maybe.

mkToStringDecl :: Name -> [(String, Name)] -> Q Dec
mkToStringDecl name map = funD name [
clause
[conP con []]
(normalB $ litE $ stringL str)
[]
| (str, con) <- map]

因此，如果我在另一个模块中导入StringLit并编写拼接，

{-# LANGUAGE TemplateHaskell #-}
module Test where
import StringLitTy
stringLitTy "EventTable" ["table1", "table2", "some_other_table"]

我可以对生成的EventTable类型的构造函数进行案例分析。这不是你在问题中要求的，但我认为它让你完成了 90% 的路程。

tableNumber Table1 = Just 1
tableNumber Table2 = Just 2
tableNumber Some_other_table = Nothing
-- for good measure:
ghci> :l Test
[1 of 2] Compiling StringLitTy      ( StringLitTy.hs, interpreted )
[2 of 2] Compiling Test             ( Test.hs, interpreted )
Ok, modules loaded: Test, StringLitTy.
ghci> :bro
data EventTable = Table1 | Table2 | Some_other_table
mkEventTable :: [Char] -> Maybe EventTable
eventTableToString :: EventTable -> [Char]
ghci> tableNumber Table1
Just 1

哦，还有一件事：由于Qmonad 允许您在拼接中运行IO操作，因此您可以(例如)查询数据库以获取表名。Template Haskell编程是"只是编程"，所以你可以用Q做所有常见的Monad事情(如traverse)：

getTablesFromDb :: IO [(String, [String])]
getTablesFromDb = {- ... -}
mkTables :: Q [Dec]
mkTables = do
tables <- runIO getTablesFromDb
concat <$> traverse (uncurry stringLitTy) tables