是否有generics-sop
模仿SYB的everywhere
/ mkT
行为的例子?
我要尝试执行的操作(但未成功完成)是将everywhere (mkT fixupSymbol)
中的main
替换为等效的Generics.SOP
构造,即使用{{1 }}递归到产品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
答案 0 :(得分:5)
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论文的小规模示例对此进行检验。与SYB的everywhere
相比,已实现的基于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
的{{1}}实例。尽管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
产生了预期的结果。