haskell - 如何使用 Template Haskell 构建多态结构？

Question

我可以写一个实例

-- In Data.Sequence.Internal
instance Lift a => Lift (Seq a) where
  ...

让用户将完全实现的序列提升到拼接中。但是假设我想要一些不同的东西来构建用于创建序列的函数？

sequenceCode :: Quote m => Seq (Code m a) -> Code m (Seq a)
sequenceCode = ???

我的想法是我可以写出类似的东西

triple :: a -> a -> a -> Seq a
triple a b c = $$(sequenceCode (fromList [[|| a ||], [|| b ||], [|| c ||]]))

并让该函数直接使用底层序列构造函数构建其序列，而不必在运行时构建和转换列表。
写 sequenceCode 这样的东西并不难直接用于序列，使用它们的内部结构(看下面的跳转)。但是，顾名思义， sequenceCode看起来很像 sequence .有没有办法概括它？片刻反射(reflection)表明 Traversable是不够的。可以用 Generic1 做点什么吗？类(class) staged generics ?我做了一些尝试，但我对那个包的理解不够好，无法知道从哪里开始。即使只使用普通的旧 GHC 泛型也有可能吗？我开始怀疑是这样，但我还没有尝试过，它肯定会毛茸茸的。

这是 Data.Sequence 的代码版本:

{-# language TemplateHaskellQuotes #-}
import Data.Sequence.Internal
import qualified Language.Haskell.TH.Syntax as TH

class Functor t => SequenceCode t where
  traverseCode :: TH.Quote m => (a -> TH.Code m b) -> t a -> TH.Code m (t b)
  traverseCode f = sequenceCode . fmap f
  sequenceCode :: TH.Quote m => t (TH.Code m a) -> TH.Code m (t a)
  sequenceCode = traverseCode id

instance SequenceCode Seq where
  sequenceCode (Seq t) = [|| Seq $$(traverseCode sequenceCode t) ||]

instance SequenceCode Elem where
  sequenceCode (Elem t) = [|| Elem $$t ||]

instance SequenceCode FingerTree where
  sequenceCode (Deep s pr m sf) =
    [|| Deep s $$(sequenceCode pr) $$(traverseCode sequenceCode m) $$(sequenceCode sf) ||]
  sequenceCode (Single a) = [|| Single $$a ||]
  sequenceCode EmptyT = [|| EmptyT ||]

instance SequenceCode Digit where
  sequenceCode (One a) = [|| One $$a ||]
  sequenceCode (Two a b) = [|| Two $$a $$b ||]
  sequenceCode (Three a b c) = [|| Three $$a $$b $$c ||]
  sequenceCode (Four a b c d) = [|| Four $$a $$b $$c $$d ||]

instance SequenceCode Node where
  sequenceCode (Node2 s x y) = [|| Node2 s $$x $$y ||]
  sequenceCode (Node3 s x y z) = [|| Node3 s $$x $$y $$z ||]

然后在另一个模块中，我们可以定义 triple如上:

triple :: a -> a -> a -> Seq a
triple a b c = $$(sequenceCode (fromList [[|| a ||], [|| b ||], [|| c ||]]))

当我用 -ddump-splices 编译它时(或 -ddump-ds )，我可以验证序列是直接构建的，而不是使用 fromList .

Answer 1

我有 uploaded a package这样做。
原来GHC.Generics足够了。但是，我实际上会使用 linear-generics相反，因为它有一个更通用的 Generic1 版本.这个想法是，通过检查一个值的通用表示，我们可以构建我们需要的所有信息来为它生成一个模板 Haskell 代码。都是很低级的!首先，一些清嗓子:

{-# language TemplateHaskellQuotes #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language ScopedTypeVariables #-}
{-# language DataKinds #-}
{-# language TypeOperators #-}
{-# language EmptyCase #-}
{-# language DefaultSignatures #-}

module Language.Haskell.TH.TraverseCode
  ( TraverseCode (..)
  , sequenceCode
  , genericTraverseCode
  , genericSequenceCode
  ) where
import Generics.Linear
import Language.Haskell.TH.Syntax
  (Code, Lift (..), Exp (..), Quote, Name)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Lib (conE)
import Data.Kind (Type)

-- for instances
import qualified Data.Functor.Product as FProd
import qualified Data.Functor.Sum as FSum
import Data.Functor.Identity
import qualified Data.Sequence.Internal as Seq
import Data.Coerce

现在我们将进入事情的本质:

class TraverseCode t where
  traverseCode :: Quote m => (a -> Code m b) -> t a -> Code m (t b)

  default traverseCode
    :: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
    => (a -> Code m b) -> t a -> Code m (t b)
  traverseCode = genericTraverseCode

sequenceCode
  :: (TraverseCode t, Quote m)
  => t (Code m a) -> Code m (t a)
sequenceCode = traverseCode id

genericSequenceCode
  :: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
  => t (Code m a) -> Code m (t a)
genericSequenceCode = TH.unsafeCodeCoerce . gtraverseCode id . from1

genericTraverseCode
  :: (Quote m, GTraverseCode (Rep1 t), Generic1 t)
  => (a -> Code m b) -> t a -> Code m (t b)
genericTraverseCode f = TH.unsafeCodeCoerce . gtraverseCode f . from1

class GTraverseCode f where
  gtraverseCode :: Quote m => (a -> Code m b) -> f a -> m Exp

为什么我们在这里使用无类型的模板 Haskell？简单:构建我们需要的表达式非常容易，但是弄清楚如何使类型对子表达式有用会很棘手。那么，当然，我们需要泛型实例。我们将一步一步地从外到内，一路收集信息。
首先我们看一下类型的东西:

instance (Datatype c, GTraverseCodeCon f)
  => GTraverseCode (D1 c f) where
  gtraverseCode f m@(M1 x) = gtraverseCodeCon pkg modl f x
    where
      pkg = packageName m
      modl = moduleName m

这为我们提供了 GHC 用于包和模块的名称。
接下来我们看看构造函数的东西:

class GTraverseCodeCon f where
  gtraverseCodeCon :: Quote m => String -> String -> (a -> Code m b) -> f a -> m Exp

instance GTraverseCodeCon V1 where
  gtraverseCodeCon _pkg _modl _f x = case x of

instance (GTraverseCodeCon f, GTraverseCodeCon g)
  => GTraverseCodeCon (f :+: g) where
  gtraverseCodeCon pkg modl f (L1 x) = gtraverseCodeCon pkg modl f x
  gtraverseCodeCon pkg modl f (R1 y) = gtraverseCodeCon pkg modl f y

instance (Constructor c, GTraverseCodeFields f)
  => GTraverseCodeCon (C1 c f) where
  gtraverseCodeCon pkg modl f m@(M1 x) = gtraverseCodeFields (conE conN) f x
    where
      conBase = conName m
      conN :: Name
      conN = TH.mkNameG_d pkg modl conBase

有趣的情况是当我们到达一个实际的构造函数时( C1)。这里我们从 Constructor 中获取构造函数的(非限定)名称。实例，并将其与包和模块名称结合起来以获得模板 Haskell Name构造函数，我们可以从中构建一个引用它的表达式。这个表达式被传递到最低级别，我们处理字段。其余的基本上是这些领域的左折叠。

class GTraverseCodeFields f where
  gtraverseCodeFields :: Quote m => m Exp -> (a -> Code m b) -> f a -> m Exp

instance GTraverseCodeFields f => GTraverseCodeFields (S1 c f) where
  gtraverseCodeFields c f (M1 x) = gtraverseCodeFields c f x

instance (GTraverseCodeFields f, GTraverseCodeFields g)
  => GTraverseCodeFields (f :*: g) where
  gtraverseCodeFields c f (x :*: y) =
    gtraverseCodeFields (gtraverseCodeFields c f x) f y

instance Lift p => GTraverseCodeFields (K1 i p) where
  gtraverseCodeFields c _f (K1 x) = [| $c x |]

instance GTraverseCodeFields Par1 where
  gtraverseCodeFields cc f (Par1 ca) =
    [| $cc $(TH.unTypeCode (f ca)) |]

instance GTraverseCodeFields U1 where
  gtraverseCodeFields cc _f U1 = cc


-- Note: this instance is *different* from the one that we'd
-- write if we were using GHC.Generics, because composition works
-- differently in Generics.Linear.
instance (GTraverseCodeFields f, TraverseCode g) => GTraverseCodeFields (f :.: g) where
  gtraverseCodeFields cc f (Comp1 x) =
    gtraverseCodeFields cc (traverseCode f) x

现在我们可以编写各种实例:

instance TraverseCode Maybe
instance TraverseCode Identity
instance TraverseCode []
instance TH.Lift a => TraverseCode (Either a)
instance TH.Lift a => TraverseCode ((,) a)
instance (TraverseCode f, TraverseCode g)
  => TraverseCode (FProd.Product f g)
instance (TraverseCode f, TraverseCode g)
  => TraverseCode (FSum.Sum f g)
instance TraverseCode V1

-- The Elem instance isn't needed for the Seq instance
instance TraverseCode Seq.Elem
instance TraverseCode Seq.Digit
instance TraverseCode Seq.Node
instance TraverseCode Seq.FingerTree

对于 Seq例如，我需要手写一些东西，因为 Seq不是 Generic1 的实例(我们不希望这样)。此外，我们并不真正想要派生实例。使用一点强制魔法，并知道一些关于如何 zipWith和 replicate在序列上工作，我们可以最小化拼接的大小以及 GHC 编译到 Core 后必须处理的类型数量。

instance TraverseCode Seq.Seq where
  -- Stick a single coercion on the outside, instead of having a bunch
  -- of `Elem` constructors on the inside.
  traverseCode f s = [|| coerceFT $$(traverseCode f ft') ||]
    where
      -- Use zipWith to make the tree representing the sequence
      -- nice and shallow.
      ft' = coerceSeq (Seq.zipWith (flip const) (Seq.replicate (Seq.length s) ()) s)
coerceFT :: Seq.FingerTree a -> Seq.Seq a
coerceFT = coerce
coerceSeq :: Seq.Seq a -> Seq.FingerTree a
coerceSeq = coerce