Question

我是Haskell的新手，所以也许我在这里缺少一些基本概念（或者可能找不到合适的扩展）。我想知道是否有一种方法可以优化或进一步抽象以下场景。这段代码似乎非常多余。

假设我有以下数据类：

data Person = Person
              { personName :: !String
              , personAge  :: !Int
              } deriving Show

data Dog = Dog
           { dogName :: !String
           , dogAge  :: !Int
           } deriving Show

假设我有一项服务而且我只关心将记录输出为字符串。实际上，字符串可能是JSON和从DB中获取的记录，但让我们看一个更简单的情况。我基本上需要一个URL令牌来获取一个合适的对象（比如，字符串“dog”会给我一个Dog，甚至只是Haskell“show”字符串，而不是明确地声明它为（value）:: Dog）。

我试图以多种方式实现这一点......似乎唯一有效的是：

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和类，但两者似乎都依赖于类型而不是基于值的多态性（字符串标识符往往会导致模糊实例出现问题）。将构造函数映射到字符串（Say，with Data.Map）会很好，但构造函数通常有不同的类型。

更新

所以，我采用的方法与我提出的问题并不完全相关，但它可能对某人有用。我确实想要保留一些记录类型，但大多数都没有增加太多的价值并且妨碍我。我所遵循的步骤如下：

使用不同/较低级别的DB驱动程序，它返回可操作的类型（例如，[ColumnDef]和[[SQLValue]]而不是元组和记录......）。
为SQLValue创建ToJSON实例 - 除了一些ByteString类型之外，大多数类型都被覆盖了，我必须处理SQLNull到Null的转换。为了保持与某些记录类型的兼容性，我的默认处理程序如下所示：toJSON = genericToJSON defaultOptions { sumEncoding = UnTaggedValue}如果需要，未标记的值应该允许人们将JSON读入已定义的数据类型（例如，Dog / Person）....
鉴于可以从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

Answer 1

如果你想在最后消费的是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

Haskell类型多态 - 映射到字符串

1 个答案: