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

Question

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

dfe*_*uer 7 generics haskell template-haskell

我可以写一个实例

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

Run Code Online (Sandbox Code Playgroud)

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

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

Run Code Online (Sandbox Code Playgroud)

我的想法是我能够写出类似的东西

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

Run Code Online (Sandbox Code Playgroud)

并让该函数直接使用底层序列构造函数构建其序列，而不必在运行时构建和转换列表。

使用它们的内部结构直接为序列编写类似的东西并不难sequenceCode（看下面的跳转）。但是，顾名思义，sequenceCode看起来很像sequence。有没有办法概括它？稍加思考就会发现这Traversable还不够。是否可以对分阶段泛型Generic1中的类做一些事情？我做了一些尝试，但我不太了解该包，不知道从哪里开始。即使只使用普通的旧 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 ||]

Run Code Online (Sandbox Code Playgroud)

然后在另一个模块中，我们可以triple像上面一样定义：

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

Run Code Online (Sandbox Code Playgroud)

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

Answer 1

dfe*_*uer 1

我已经上传了一个包。

事实证明这就GHC.Generics足够了。然而，我实际上会使用linear-generics它，因为它有一个更通用的版本Generic1。这个想法是，通过检查值的通用表示，我们可以构建为其生成 Template 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

Run Code Online (Sandbox Code Playgroud)

现在我们将进入主题：

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

Run Code Online (Sandbox Code Playgroud)

为什么我们使用无类型模板 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

Run Code Online (Sandbox Code Playgroud)

这为我们提供了 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

Run Code Online (Sandbox Code Playgroud)

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

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

Run Code Online (Sandbox Code Playgroud)

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

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

Run Code Online (Sandbox Code Playgroud)

对于Seq我所追求的实例，我们需要手动编写一些东西，因为Seq不是的实例Generic1（而且我们不希望它是）。此外，我们并不真正想要派生实例。使用一些强制转换魔法，并了解一些关于序列如何工作的知识zipWith，replicate我们可以最小化拼接的大小以及编译到 Core 后 GHC 必须处理的类型数量。

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

Run Code Online (Sandbox Code Playgroud)

归档时间：	3 年，9 月前
查看次数：	170 次
最近记录：	3 年，9 月前