haskell - Generics.SOP 等效于无处不在/mkT(替代产品)

Question

是否有模仿 SYB 的 generics-sop/everywhere 行为的 mkT 示例？

我正在尝试做的，但没有看到如何成功地做到这一点，是将 everywhere (mkT fixupSymbol) 中的 main 替换为等效的 Generics.SOP 构造，即，使用 Generics.SOP 递归到产品 (I (AbsAddr value)) 并将其替换为 (I (SymAddr label)) 。

我可以将符号表传递给 gformatOperands ，从而污染 formatOperands 签名。这似乎不是最理想的。

如果没有 fixupSymbol ，输出将如下所示:

LD   B, 0x0000
LD   C, 0x1234
CALL 0x4567

将地址解析为符号标签:

gensop % stack ghci
Using main module: 1. Package `gensop' component exe:gensop with main-is file: <...>/Main.hs
gensop-0.1: configure (exe)
Configuring gensop-0.1...
gensop-0.1: initial-build-steps (exe)
Configuring GHCi with the following packages: gensop
GHCi, version 8.6.3: http://www.haskell.org/ghc/  :? for help
[1 of 1] Compiling Main             ( <...>/Main.hs, interpreted )
*Main> main
LD   B, 0x0000
LD   C, label1
CALL label2
*Main>

缩减版代码:

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Data.Data
import Data.Foldable (foldl)
import Data.Word (Word8, Word16)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Text.Printf
import Generics.SOP
import Generics.SOP.TH (deriveGeneric)
import Data.Generics.Aliases (mkT)
import Data.Generics.Schemes (everywhere)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq


type Z80addr = Word16
type Z80word = Word8

class Z80operand x where
  formatOperand :: x -> Text

main :: IO()
main = mapM_ T.putStrLn (foldl printIns Seq.empty $ everywhere (mkT fixupSymbol) insnSeq)
-- -------------------------------------------------^ Does this have a Generics.SOP equivalent?
  where
    printIns accum ins = accum |> T.concat ([mnemonic, gFormatOperands] <*> [ins])

    mnemonic (LD _)   = "LD   "
    mnemonic (CALL _) = "CALL "

    -- Generics.SOP: Fairly straightforward
    gFormatOperands {-elt-} =
      T.intercalate ", " . hcollapse . hcmap disOperandProxy (mapIK formatOperand) . from {-elt-}
      where
        disOperandProxy = Proxy :: Proxy Z80operand

    -- Translate an absolute address, generally hidden inside an instruction operand, into a symbolic address
    -- if present in the symbol table.
    fixupSymbol addr@(AbsAddr absAddr) = maybe addr SymAddr (absAddr `H.lookup` symtab)
    fixupSymbol other                  = other

    insnSeq :: Seq Z80instruction
    insnSeq = Seq.singleton (LD (Reg8Imm B 0x0))
              |> (LD (Reg8Indirect C (AbsAddr 0x1234)))
              |> (CALL (AbsAddr 0x4567))

    symtab :: HashMap Z80addr Text
    symtab = H.fromList [ (0x1234, "label1"), (0x4567, "label2")]

-- | Symbolic and absolute addresses. Absolute addresses can be translated into symbolic
-- labels.
data SymAbsAddr  = AbsAddr Z80addr | SymAddr Text
  deriving (Eq, Ord, Typeable, Data)

data Z80reg8 = A | B | C
  deriving (Eq, Ord, Typeable, Data)

-- | Cut down version of the Z80 instruction set
data Z80instruction = LD OperLD | CALL SymAbsAddr
  deriving (Eq, Ord, Typeable, Data)

-- | Load operands
data OperLD = Reg8Imm Z80reg8 Z80word | Reg8Indirect Z80reg8 SymAbsAddr
  deriving (Eq, Ord, Typeable, Data)

$(deriveGeneric ''SymAbsAddr)
$(deriveGeneric ''Z80reg8)
$(deriveGeneric ''Z80instruction)
$(deriveGeneric ''OperLD)

instance Z80operand Z80word where
  formatOperand word = T.pack $ printf "0x%04x" word

instance Z80operand SymAbsAddr where
  formatOperand (AbsAddr addr)  = T.pack $ printf "0x04x" addr
  formatOperand (SymAddr label) = label

instance Z80operand Z80reg8 where
  formatOperand A = "A"
  formatOperand B = "B"
  formatOperand C = "C"

instance Z80operand OperLD where
  formatOperand (Reg8Imm reg imm) = T.concat [formatOperand reg, ", ", formatOperand imm]
  formatOperand (Reg8Indirect reg addr) = T.concat [formatOperand reg, ", ", formatOperand addr]

gensop.cabal 文件:

cabal-version:  >= 1.12
name:           gensop
version:        0.1
build-type:     Simple
author:         scooter-me-fecit
description:    No description.
license:        GPL-3

executable gensop
  default-language:     Haskell2010
  main-is: Main.hs
  build-depends:
    base,
    containers,
    bytestring,
    generics-sop,
    syb,
    text,
    unordered-containers

  default-extensions:
    OverloadedStrings,
    FlexibleInstances

  ghc-options: -Wall

Answer 1

generics-sop没有为递归遍历方案提供等价物，例如这些函数。如果您需要在这个库中处理递归，可能的解决方案是实现它们。虽然，在 SOP 中定义这样的函数会带来一些困难，因为它对数据有一个核心的通用 View ，不区分递归节点和叶子。可以使用封闭类型族 (CTF) 和某些类型类机制来管理此设置中的递归。封闭型系列允许您:

实现类型安全转换，这是定义 mkT 所必需的,

解决递归和非递归节点的情况——不同
类型类的实例——否则会重叠。 (另外一个选项
正在对重叠实例使用编译指示，这是最近的 GHC 功能；
然而，关于重叠实例在
Haskell 社区，所以这个解决方案通常被认为是
不受欢迎的。)

使用 CTF 处理递归已在一篇未发表的论文“Handling Recursion in Generic Programming Using Closed Type Families”中进行了描述，该论文使用 generics-sop图书馆作为案例研究；它提供了在 SOP 中定义递归方案的示例。

SYB everywhere支持相互递归的数据类型族。以下实现允许将它们指定为类型级列表。

{-# LANGUAGE DeriveGeneric, TypeFamilies, DataKinds,
             TypeApplications, ScopedTypeVariables, MultiParamTypeClasses,
             ConstraintKinds, FlexibleContexts, AllowAmbiguousTypes,
             FlexibleInstances, UndecidableInstances,
             UndecidableSuperClasses, TypeOperators, RankNTypes #-}

import Generics.SOP
import Generics.SOP.NS

import GHC.Exts (Constraint)
import Data.Type.Equality

type family Equal a x :: Bool where
  Equal a a = 'True
  Equal _ _ = 'False

class DecideEq (eq :: Bool) (a :: *) (b :: *) where
  decideEq :: Maybe (b :~: a)
instance a ~ b => DecideEq True a b where
  decideEq = Just Refl
instance DecideEq False a b where
  decideEq = Nothing

type ProofCast a b = DecideEq (Equal a b) a b

castEq :: forall a b. ProofCast a b => b -> Maybe a
castEq t = (\d -> castWith d t) <$> decideEq @(Equal a b)

type Transform a b = (Generic a, Generic b, ProofCast a b, ProofCast b a)

mkT :: Transform a b => (a -> a) -> b -> b
mkT f x = maybe x id $ castEq =<< f <$> castEq x

type family In (a :: *) (fam :: [*]) :: Bool where
    In a   ([a] ': fam) = 'True
    In [a] (a   ': fam) = 'True
    In a   (a   ': fam) = 'True
    In a   (_   ': fam) = In a fam
    In _   '[]          = 'False

class CaseEverywhere' (inFam :: Bool) (c :: * -> Constraint)
                      (fam :: [*]) (x :: *) (y :: *) where
  caseEverywhere' :: (forall b . c b => b -> b) -> I x -> I y

instance c x => CaseEverywhere' 'False c fam x x where
  caseEverywhere' f = I . f . unI
instance (c x, Everywhere x c fam) => CaseEverywhere' 'True c fam x x where
  caseEverywhere' f = I . f . everywhere @fam @c f . unI

class    CaseEverywhere' (In x fam) c fam x y => CaseEverywhere c fam x y
instance CaseEverywhere' (In x fam) c fam x y => CaseEverywhere c fam x y

caseEverywhere :: forall c fam x y . CaseEverywhere c fam x y
               => (forall b . c b => b -> b) -> I x -> I y
caseEverywhere = caseEverywhere' @(In x fam) @c @fam

type Everywhere a c fam =
  (Generic a, AllZip2 (CaseEverywhere c fam) (Code a) (Code a))

everywhere :: forall fam c a . Everywhere a c fam
           => (forall b . c b => b -> b) -> a -> a
everywhere f = to . everywhere_SOP . from
  where
    everywhere_SOP = trans_SOP (Proxy @(CaseEverywhere c fam)) $
                               caseEverywhere @c @fam f

用法
首先，可以通过 SYB 论文中的一个小规模示例来检验这一点。已实现的基于 SOP 的 everywhere ，与 SYB 的相比，额外接受两个类型参数，通过显式类型应用程序传递。第一个将一系列相互递归的数据类型指定为类型列表。遍历将仅将那些类型在该列表中指定的节点视为递归。需要第二个参数来为编译器提供类型转换的“证明”对象。 T Transform 的同义词约束用于允许其部分应用。

data Company = C [Dept]
data Dept = D Name Manager [SubUnit]
data SubUnit = PU Employee | DU Dept
data Employee = E Person Salary
data Person = P Name Address
data Salary = S Float
type Manager = Employee
type Name = String
type Address = String

class    Transform a b => T a b
instance Transform a b => T a b

type CompanyF = '[Company, Dept, SubUnit, Employee]

increase :: Float -> Company -> Company
increase k = everywhere @CompanyF @(T Salary) (mkT (incS k))

incS :: Float -> Salary -> Salary
incS k (Sal s) = Sal (s * (1 + k))

定义 everywhere/ mkT函数已准备好在您的代码中使用，但它遗漏了一些 Generic实例。申请 everywhere至 insnSeq , 你需要一个 Generic (Seq Z80instruction)实例。然而你无法获得它，因为 Data.Sequence模块不导出它的内部表示。一个可能的修复方法是应用 fmap到序列。所以现在你可以写:

{-# LANGUAGE TypeApplications #-}

...

type Z80 = '[SymAbsAddr, Z80reg8, Z80instruction, OperLD]

main :: IO()
main = mapM_ T.putStrLn (foldl printIns Seq.empty $
  fmap (everywhere @Z80 @(T SymAbsAddr) (mkT fixupSymbol)) insnSeq)

您应该提供 Generic遍历的所有类型节点的实例，递归和非递归。所以接下来，这需要 Generic Word8 的实例, Word16 , 和 Text .而 Generic Text可以通过 deriveGeneric 生成实例，其他人不能，因为他们特殊的 GHC 表示。所以你必须手动完成；这个定义很简单:

$(deriveGeneric ''Text)

instance Generic Word8 where
  type Code Word8 = '[ '[Word8]]
  from x                        = SOP (Z (I x :* Nil))
  to   (SOP ((Z (I x :* Nil)))) = x

instance Generic Word16 where
  type Code Word16 = '[ '[Word16]]
  from x                        = SOP (Z (I x :* Nil))
  to   (SOP ((Z (I x :* Nil)))) = x

此代码是样板代码，但最新的 GHC 扩展 DerivingVia可以很好地简化这一点，减少第二个定义。希望通过独立派生的可能性来改进这个有用的功能，因此可以改为:

deriving via Word8 instance Generic Word16

整个代码现在运行良好， main产生预期的结果。