Question

背景

我想编写一些库代码，它在内部使用DSum来操作用户的数据类型。 DSum需要一个具有单一类型参数的“标记”类型。但是我希望我的代码可以使用任何旧的具体类型。所以，我想只取用户的类型并自动生成标签类型。我在这里问了一个非常相似的问题How can I programatically produce this datatype from the other?，得到了一个很好的答案。答案依赖于TH，主要是因为它可以创建顶级声明。但是，我实际上并不关心顶级声明，如果可能的话，我宁愿避免使用TH。

问题

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

data Magic t a ...

给出一些任意和类型，例如

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

Magic SomeUserType相当于可以与DSum一起使用的'tag'类型？

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

Answer 1

与此处声称的人不同，使用正确的库 - generics-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类型族中，它计算类型的泛型表示，作为类型列表的列表。类型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" ]

由于这是以泛型类型函数表示的，因此您可以在标记上编写泛型操作。例如，对于任何exists x . (GTag t x, x)，t与Generic 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等函数必须模式匹配才能检索存储在构造函数中的单个值。

Answer 2

我不确定你是否可以免除TH，因为正如评论中所指出的，你仍然需要在一天结束时制作一个类型。正如本杰明所说，你可能正在寻找data family。

您致电Magic，我将其称为Tagged。

以下是 tag.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)

并且，一个示例用例（一直到涉及DSum的内容）：

{-# LANGUAGE TemplateHaskell, GADTs, TypeFamilies #-}
module Test where

import Data.Dependent.Sum
import Data.Functor.Identity
import Tag

-- Some data types
data SomeUserType1 = Foo Int | Bar String
data SomeUserType2 = Fooo Int | Baar Char | Baaz Bool String
data SomeAwkUserType = Foooo Int

-- Data family for all Tagged things
data family Tagged t a

-- Generated data family instances
makeTag ''SomeUserType1 ''Tagged
makeTag ''SomeUserType2 ''Tagged
makeTag ''SomeAwkUserType ''Tagged

--  A sample DSum's use case
toString :: DSum (Tagged SomeUserType1) Identity -> String
toString (TagFoo :=> Identity int) = show int
toString (TagBar :=> Identity str) = str

这最终会为每种类型生成data family个标记实例。如果您有任何问题，请告诉我。

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

2 个答案: