我可以编写一个实例
-- 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。有没有一种方法可以概括它？片刻的反思表明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 ||]
然后在另一个模块中，我们可以如上定义triple：
triple :: a -> a -> a -> Seq a
triple a b c = $$(sequenceCode (fromList [[|| a ||], [|| b ||], [|| c ||]]))
当我用-ddump-splices(或-ddump-ds(编译它时，我可以验证序列是直接构建的，而不是使用fromList。
我已经上传了一个包。
结果表明CCD_ 11是足够的。然而，我实际上会使用linear-generics，因为它有一个更通用的Generic1版本。我们的想法是，通过检查一个值的通用表示，我们可以建立为它生成TemplateHaskell代码所需的所有信息。这一切都是非常低级的！首先，一些清嗓子：
{-# 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实例中获取构造函数的(非限定(名称，并将其与包和模块名称相结合，以获得构造函数的Template HaskellName，从中我们可以构建一个引用它的表达式。这个表达式被传递到最底层，在那里我们处理字段。其余的基本上是在这些田地上向左折叠。
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