如何使用模板 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 ||]]))

並讓 function 直接使用底層序列構造函數構建其序列，而不必在運行時構建和轉換列表。

使用它們的內部結構直接為序列編寫類似sequenceCode之類的東西並不難（看下面的跳轉）。 但是，顧名思義， sequenceCode看起來很像sequence 。 有沒有辦法概括它？ 片刻反思表明Traversable是不夠的。 是否可以在分階段的 generics中使用Generic1 class 做些什么？ 我做了一些嘗試，但我不明白 package 足夠好，無法知道正確的起點。 即使只使用普通的舊 GHC generics 也有可能嗎？ 我開始懷疑是這樣，但我還沒有嘗試過，它肯定會毛茸茸的。

---

這是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

事實證明， GHC.Generics就足夠了。 但是，我實際上將使用linear-generics ，因為它具有更通用的Generic1版本。 這個想法是，通過檢查一個值的通用表示，我們可以建立我們需要的所有信息，為它生成一個模板 Haskell 代碼。 這都是相當低級的，首先：一些清嗓子：

{-# language TemplateHaskellQuotes #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language ScopedTypeVariables #-}
{-# language KindSignatures #-}
{-# language DataKinds #-}
{-# language TypeApplications #-}
{-# 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？ 簡單：構建我們需要的表達式非常容易，但是弄清楚如何使類型對子表達式有用會很棘手。 那么，當然，我們需要泛型實例。 我們將一步一步地從外到內，一路收集信息。 為方便起見，讓我們定義一個奇怪的代理：

data Goop (d :: Meta) (f :: Type -> Type) a = Goop

首先我們看一下類型的東西：

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

這為我們提供了 GHC 用於 package 和模塊的名稱。

接下來我們看看構造函數的東西：

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

-- This instance seems totally useless, but it's obviously valid.
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 (M1 x) = gtraverseCodeFields (conE conN) f x
    where
      conBase = conName (Goop @c @f)
      conN :: Name
      conN = TH.mkNameG_d pkg modl conBase

有趣的情況是當我們到達一個實際的構造函數（ C1 ）時。 在這里，我們從Constructor實例中獲取構造函數的（非限定）名稱，並將其與 package 和模塊名稱結合起來，得到構造函數的模板 Haskell Name ，我們可以從中構建一個引用它的表達式。 這個表達式被傳遞到最低級別，我們處理字段。 rest 基本上是這些領域的左折。

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的實例（我們不希望它是）。 此外，我們並不真正想要派生實例。 使用一點強制轉換魔法，並了解一點Data.Sequence.zipWith的操作方式，我們可以最小化拼接的大小以及 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