在没有模板Haskell的情况下，如何为任何数据类型生成用于DSum的标记类型？_Haskell_Generic Programming

在没有模板Haskell的情况下，如何为任何数据类型生成用于DSum的标记类型？

haskell

在没有模板Haskell的情况下，如何为任何数据类型生成用于DSum的标记类型？,haskell,generic-programming,Haskell,Generic Programming,背景我想写一些库代码，它在内部使用DSum来操作用户的数据类型。DSum需要具有单个类型参数的“标记”类型。但是，我希望我的代码只处理任何旧的具体类型。所以，我只想获取用户的类型并自动生成标记类型。我在这里问了一个非常类似的问题，得到了一个很好的答案。这个答案依赖于TH，主要是为了创建顶级声明。然而，我实际上并不关心顶层声明，如果可能的话，我更愿意避免TH 问题 [如何]我可以使用一些通用编程技术编写数据类型 data Magic t a ... 如果给定了任意和类型，例如 data Som

背景

我想写一些库代码，它在内部使用DSum来操作用户的数据类型。DSum需要具有单个类型参数的“标记”类型。但是，我希望我的代码只处理任何旧的具体类型。所以，我只想获取用户的类型并自动生成标记类型。我在这里问了一个非常类似的问题，得到了一个很好的答案。这个答案依赖于TH，主要是为了创建顶级声明。然而，我实际上并不关心顶层声明，如果可能的话，我更愿意避免TH

问题

[如何]我可以使用一些通用编程技术编写数据类型

data Magic t a ...

如果给定了任意和类型，例如

data SomeUserType = Foo Int | Bar Char | Baz Bool String

Magic SomeUserType

是否等同于此可与DSum一起使用的“标记”类型

data TagSomeUserType a where
  TagFoo :: TagSomeUserType Int
  TagBar :: TagSomeUserType Char
  TagBaz :: TagSomeUserType (Bool, String)

我不确定你是否可以省去TH，因为正如评论中提到的，你仍然需要在一天结束时打字。正如Benjamin所指出的，您可能正在寻找一个

数据族

你所说的

Magic

，我将称之为

taged

这是您需要的调整后的代码，用于标记.hs

{-# LANGUAGE TemplateHaskell #-}

module Tag where

import Language.Haskell.TH

makeTag :: Name -> Name -> DecsQ
makeTag name tag = do
    -- Reify the data declaration to get the constructors.
    -- Note we are forcing there to be no type variables...
    (TyConI (DataD _ _ [] _ cons _)) <- reify name

    pure [ DataInstD [] tag [(ConT name), (VarT (mkName "a"))] Nothing (tagCon <$> cons) [] ]
  where
  -- Given a constructor, construct the corresponding constructor for
  -- Tag GADT
  tagCon :: Con -> Con
  tagCon (NormalC conName args) =
    let tys = fmap snd args
        tagType = foldl AppT (TupleT (length tys)) tys
    in GadtC [mkName ("Tag" ++ nameBase conName)] []
             (AppT (AppT (ConT tag) (ConT name)) tagType)

这将为每种类型生成

数据族

标记实例。如果您有任何问题，请告诉我。

我不确定您是否可以省去TH，因为如评论中所述，您仍然需要在一天结束时打字。正如Benjamin所指出的，您可能正在寻找一个

数据族

你所说的

Magic

，我将称之为

taged

这是您需要的调整后的代码，用于标记.hs

{-# LANGUAGE TemplateHaskell #-}

module Tag where

import Language.Haskell.TH

makeTag :: Name -> Name -> DecsQ
makeTag name tag = do
    -- Reify the data declaration to get the constructors.
    -- Note we are forcing there to be no type variables...
    (TyConI (DataD _ _ [] _ cons _)) <- reify name

    pure [ DataInstD [] tag [(ConT name), (VarT (mkName "a"))] Nothing (tagCon <$> cons) [] ]
  where
  -- Given a constructor, construct the corresponding constructor for
  -- Tag GADT
  tagCon :: Con -> Con
  tagCon (NormalC conName args) =
    let tys = fmap snd args
        tagType = foldl AppT (TupleT (length tys)) tys
    in GadtC [mkName ("Tag" ++ nameBase conName)] []
             (AppT (AppT (ConT tag) (ConT name)) tagType)

这将为每种类型生成

数据族

标记实例。如果您有任何问题，请告诉我。

与这里的一些人所声称的不同，定义这样的类型是完全明智的（事实上非常简单，有正确的库-

泛型sop

）。基本上，所有机器都已由该库提供：

{-# LANGUAGE PatternSynonyms, PolyKinds, DeriveGeneric #-} 

import Generics.SOP 
import qualified GHC.Generics as GHC 
import Data.Dependent.Sum

data Tup2List :: * -> [*] -> * where 
  Tup0 :: Tup2List () '[] 
  Tup1 :: Tup2List x '[ x ] 
  TupS :: Tup2List r (x ': xs) -> Tup2List (a, r) (a ': x ': xs) 

newtype GTag t i = GTag { unTag :: NS (Tup2List i) (Code t) }

类型

GTag

就是您所说的

Magic

。实际的“魔力”发生在

code

type族中，它将类型的泛型表示作为类型列表进行计算。类型

NS（Tup2List i）xs

意味着对于其中一个

xs

，

Tup2List i

有效-这只是一个参数列表同构于某个元组的证明

您需要的所有类都可以派生：

data SomeUserType = Foo Int | Bar Char | Baz Bool String 
  deriving (GHC.Generic, Show) 
instance Generic SomeUserType

可以为此类型有效的标记定义一些模式同义词：

pattern TagFoo :: () => (x ~ Int) => GTag SomeUserType x 
pattern TagFoo = GTag (Z Tup1) 

pattern TagBar :: () => (x ~ Char) => GTag SomeUserType x 
pattern TagBar = GTag (S (Z Tup1)) 

pattern TagBaz :: () => (x ~ (Bool, String)) => GTag SomeUserType x 
pattern TagBaz = GTag (S (S (Z (TupS Tup1))))

还有一个简单的测试：

fun0 :: GTag SomeUserType i -> i -> String 
fun0 TagFoo i = replicate i 'a' 
fun0 TagBar c = c : [] 
fun0 TagBaz (b,s) = (if b then show else id) s 

fun0' = \(t :& v) -> fun0 t v 

main = mapM_ (putStrLn . fun0' . toTagVal) 
          [ Foo 10, Bar 'q', Baz True "hello", Baz False "world" ]

因为这是用泛型类型函数表示的，所以可以在标记上编写泛型操作。例如，

存在于x。（GTag t x，x）

与任何

通用t

的

同构：

type GTagVal t = DSum (GTag t) I 

pattern (:&) :: forall (t :: * -> *). () => forall a. t a -> a -> DSum t I
pattern t :& a = t :=> I a     

toTagValG_Con :: NP I xs -> (forall i . Tup2List i xs -> i -> r) -> r 
toTagValG_Con Nil k = k Tup0 () 
toTagValG_Con (I x :* Nil) k = k Tup1 x
toTagValG_Con (I x :* y :* ys) k = toTagValG_Con (y :* ys) (\tp vl -> k (TupS tp) (x, vl))

toTagValG :: NS (NP I) xss -> (forall i . NS (Tup2List i) xss -> i -> r) -> r 
toTagValG (Z x) k = toTagValG_Con x (k . Z)
toTagValG (S q) k = toTagValG q (k . S)

fromTagValG_Con :: i -> Tup2List i xs -> NP I xs 
fromTagValG_Con i Tup0 = case i of { () -> Nil } 
fromTagValG_Con x Tup1 = I x :* Nil 
fromTagValG_Con xs (TupS tg) = I (fst xs) :* fromTagValG_Con (snd xs) tg 

toTagVal :: Generic a => a -> GTagVal a 
toTagVal a = toTagValG (unSOP $ from a) ((:&) . GTag)

fromTagVal :: Generic a => GTagVal a -> a 
fromTagVal (GTag tg :& vl) = to $ SOP $ hmap (fromTagValG_Con vl) tg

至于需要

Tup2List

，原因很简单，在您的示例中，您将两个参数（

Baz Bool String

）的构造函数表示为

（Bool，String）

元组上的标记

您还可以将其实现为

type HList = NP I -- from generics-sop 

data Tup2List i xs where Tup2List :: Tup2List (HList xs) xs

它将参数表示为异构列表，甚至更简单

newtype GTag t i = GTag { unTag :: NS ((:~:) i) (Code t) }
type GTagVal t = DSum (GTag t) HList  

fun0 :: GTag SomeUserType i -> HList i -> String 
fun0 TagFoo (I i :* Nil) = replicate i 'a' 
fun0 ...

然而，元组表示的优点是一元元组被“投影”到元组中的单个值（即，代替

（x，（））

）。如果以明显的方式表示参数，则函数（如

fun0

）必须进行模式匹配，才能检索存储在构造函数中的单个值

与这里的一些人所声称的不同，定义这样一个类型是完全明智的（事实上非常简单，有了正确的库-

泛型sop