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

Question

generics-sop有没有模仿 SYB everywhere/mkT行为的例子？

我正在尝试做的，但没有看到如何成功地做到这一点，是将everywhere (mkT fixupSymbol)in替换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

标签： haskell

Answer 1

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

1. 实现类型安全的转换，这是定义所需的mkT，
2. 解决递归和非递归节点（类型类的不同实例）的情况，否则它们会重叠。（另一种选择是对重叠实例使用编译指示，这是最近的 GHC 功能；但是，在 Haskell 社区中对重叠实例存在一些偏见，因此这种解决方案通常被认为是不受欢迎的。）

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

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

{-# 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 论文的小规模示例来检验。everywhere与 SYB 的相比，实现的基于 SOP 的额外采用两个类型参数，通过显式类型应用程序传递。第一个将一系列相互递归的数据类型指定为类型列表。遍历将仅将那些类型在该列表中指定的节点视为递归。需要第二个参数来为编译器提供类型转换的“证明”对象。约束的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实例。虽然可以通过 生成实例，但其他实例不能，因为它们具有特殊的 GHC 表示。所以你必须手动完成；这个定义很简单：Word8Word16TextGeneric TextderiveGeneric

$(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产生了预期的结果。