是否有generics-sop模仿SYB everywhere/ mkT行为的例子？
我试图做的,但没有看到如何成功地做,是用等效的结构替换everywhere (mkT fixupSymbol)in ,即用于递归到产品并替换它.mainGenerics.SOPGenerics.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
generics-sop没有为递归遍历方案提供等价物,例如这些函数.如果您需要在此库中处理递归,可能的解决方案是实现它们.虽然在SOP中定义这样的函数与某些困难有关,因为它具有对数据的核心通用视图,其不区分递归节点和叶子.可以使用闭合类型族(CTF)和某些类型类机制来管理此设置中的递归.封闭式家庭允许您:
mkT,在未发表的论文"处理使用封闭式家庭的通用编程中的递归"中描述了使用CTF来处理递归,该论文使用该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论文中的小规模示例来检查.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的情况下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产生预期的结果.