我是Haskell的新手，所以也许我在这里缺少一些基本概念(或者可能没有找到合适的扩展(。我想知道是否有办法优化或进一步抽象以下场景。 这段代码似乎非常多余。
假设我有以下数据类：
data Person = Person
{ personName :: !String
, personAge :: !Int
} deriving Show
data Dog = Dog
{ dogName :: !String
, dogAge :: !Int
} deriving Show
假设我有一个服务，我只关心将记录输出为字符串。 实际上，字符串可能是 JSON 和从数据库获取的记录，但让我们举一个更简单的情况。 我基本上需要一个URL令牌来获取适当的对象(例如，字符串"dog"会给我一个Dog，甚至只是Haskell"show"字符串，而没有明确声明它为(value(：:D og(。
我试图以多种方式实现这一点......似乎唯一有效的是以下内容：
data Creature = DogC Dog
| PersonC Person
deriving Show
fromString :: String -> Maybe Creature
fromString "dog" = Just $ DogC $ Dog "muffin" 8
fromString "person" = Just $ PersonC $ Person "John" 22
fromString _ = Nothing
main :: IO ()
main = do
putStrLn $ show $ fromString "dog"
我不完全喜欢新类型，也不完全喜欢fromString声明列表。 为了从原始数据声明中受益，我可能需要编写一个同样乏味的表达式(例如，"fromCreature"(将 Creature 恢复为我的原始类型。此信息可能会更改，因此我可能需要 TH 进行一些声明......
有没有办法解决这个问题？ 我摆弄了 GADT 和类，但两者似乎都依赖于基于类型而不是基于值的多态性(字符串标识符往往会导致不明确的实例问题(。 将构造函数映射到字符串(例如，使用 Data.Map(会很好，但构造函数通常具有不同的类型。
更新
因此，我采用了一种与我提出的问题并不完全相关的方法，但它可能对某人有用。我确实想保留一些记录类型，但大多数记录类型并没有增加太多价值，并且妨碍了我。我遵循的步骤是这样的：
- 使用不同/较低级别的数据库驱动程序，该驱动程序返回可行的类型(例如，[ColumnDef] 和 [[SQLValue]] 而不是元组和记录......
- 为 SQLValue 创建 ToJSON 实例 -- 除了少数 ByteString 类型外，涵盖了大多数类型，我必须处理 SQLNull 到 Null 的转换。 为了保持与某些记录类型的兼容性，我的默认处理程序如下所示：
toJSON = genericToJSON defaultOptions { sumEncoding = UnTaggedValue}如果需要，未标记的值应该允许将 JSON 读取到定义的数据类型(例如，狗/人(。 - 鉴于列名可以从 ColumnDef 访问，我编写了一个表达式，将 [ColumnDef] 和 [SqlValue] 压缩到 Aeson 兼容键值对的列表，例如：
toJsPairs :: [ColumnDef] -> [SqlValue] -> [(Text,Value)] - 然后，我编写了一个表达式来从表名中获取 JSON，它或多或少充当我的"通用调度程序"。 它引用了授权表的列表，因此它没有听起来那么疯狂。
代码看起来有点像这样(使用 mysql-haskell(。
{-# LANGUAGE OverloadedStrings #-}
import qualified Control.Applicative as App
import Database.MySQL.Base
import qualified System.IO.Streams as Streams
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Types
import Data.Text.Encoding
import Data.String (fromString)
import Data.ByteString.Internal
import qualified Data.ByteString.Lazy.Internal as BLI
import Data.HashMap.Strict (fromList)
appConnectInfo = defaultConnectInfo {
ciUser = "some_user"
, ciPassword = "some_password"
, ciDatabase = "some_db"
}
instance FromJSON ByteString where
parseJSON (String s) = pure $ encodeUtf8 s
parseJSON _ = App.empty
instance ToJSON ByteString where
toJSON = String . decodeUtf8
instance ToJSON MySQLValue where
toJSON (MySQLNull) = Null
toJSON x = genericToJSON defaultOptions
{ sumEncoding = UntaggedValue } x
-- This expression should fail on dimensional mismatch.
-- It's stupidly lenient, but really dimensional mismatch should
-- never occur...
toJsPairs :: [ColumnDef] -> [MySQLValue] -> [(Text,Value)]
toJsPairs [] _ = []
toJsPairs _ [] = []
toJsPairs (x:xs) (y:ys) = (txt x, toJSON y):toJsPairs xs ys
where
-- Implement any modifications to the key names here
txt = decodeUtf8.columnName
listRecords :: String -> IO BLI.ByteString
listRecords tbl = do
conn <- connect appConnectInfo
-- This is clearly an injection vulnerability.
-- Implemented, however, the values for 'tbl' are intensely
-- vetted. This is just an example.
(defs, is) <- query_ conn $ fromString ( "SELECT * FROM `" ++ tbl ++ "` LIMIT 100")
rcrds <- Streams.toList is
return $ encodePretty $ map (jsnobj defs) rcrds
where
jsnobj :: [ColumnDef] -> [MySQLValue] -> Value
jsnobj defs x = Object $ fromList $ toJsPairs defs x
如果你想在最后使用json值 - 这可能是有意义的 使用 AESON 库将结果表示为 JSON 值：
{-# LANGUAGE DeriveGeneric #-}
import Data.Aeson
import GHC.Generics
data Dog = Dog Int String deriving (Show, Generic)
data Cat = Cat Int String deriving (Show, Generic)
-- here I'm using instance derived with generics, but you can write one by
-- hands
instance ToJSON Dog
instance ToJSON Cat
-- actions to get stuff from db
getDog :: Monad m => Int -> m Dog
getDog i = return (Dog i (show i))
getCat :: Monad m => Int -> m Cat
getCat i = return (Cat i (show i))
-- dispatcher - picks which action to use
getAnimal :: Monad m => String -> Int -> m (Maybe Value)
getAnimal "dog" i = Just . toJSON <$> getDog i
getAnimal "cat" i = Just . toJSON <$> getCat i
getAnimal _ _ = return Nothing
main :: IO ()
main = do
getAnimal "dog" 2 >>= print
getAnimal "cat" 3 >>= print
getAnimal "chupakabra" 12 >>= print
高能魔法版
class Monad m => MonadAnimal m where
-- basically you want something that fetches extra argumets from HTTP or
-- whatevere, perform DB query and so on.
class Animal a where
animalName :: Proxy a -> String
animalGetter :: MonadAnimal m => m a
locateAnimals :: MonadAnimal m => Q [(String, m Value)]
locateAnimals -- implement using TH (reify function is your friend). It should look for
-- all the animal instances in scope and make a list from them with serialized
-- fetcher.
-- with that in place dispatcher should be easy to implement