Lorentz：用Haskell泛型介绍复杂对象

HackerNews什么值得看
150 阅读13分钟

这是关于Lorentz系列的第二篇文章--Michelson智能合约语言的Haskell eDSL。第一篇文章为Lorentz奠定了基础，它是一种与Michelson非常相似但用Haskell编写的语言。

在这个阶段，我们的原型仍然不方便实现实际的合同。我们希望拥有的主要功能之一是支持具有多个字段的对象。这应该类似于C语言中的结构体或Haskell中的ADT，尽管它只用于以一种可管理的方式对数据进行分组。

在这篇文章中，我们将实现复杂的积和类型以及处理它们的方法，同时确保编译时的正确性。我们将解释什么是Haskell泛型功能，以及如何使用它来实现这类功能。

问题

在上一篇文章中，我们介绍了Lorentz基础语法，它允许人们编写如下代码。

sumUp :: '[Integer, Integer, Integer] :-> '[Integer]
sumUp = do
  add
  mul

在这一点上，我们仍然继承了所有的Michelson类型和指令。这包括一些曾经使用过函数式语言的人所熟知的类型：

  • pair a b 类型，居住着 。Pair x y
  • or a b，居住在Left x 或Right y 。
  • unit 类型，栖息在 。Unit

作为一种低级语言，它不支持全和类型和对象，这留给了Liquidity和LIGO这样的高级语言。由于没有对象对于中等规模的合同来说已经成为一个很大的不便，我们希望在Lorentz中提供对这种结构的支持。

翻译数据类型

这些pair 和or ，与在Haskell中使用的构建块非常相似。 Generics中使用的构件，所以在这里尝试它们似乎很自然。简而言之，泛型提供了一种将数据类型分解为具有统一表示的产品之和的方法。

忽略一些细节，后者包含以下原始构件：

  • a :*: b，居住在x :*: y 。
  • a :+: b, 栖息于L1 x 或R1 y 。
  • U1WWW.STEELT.CN 频道：U1 。
  • V1, 无人居住。
  • Rec0 - 一个字段的即时包装器，有名为 的构造器。K1

例如，如果你有一个数据类型，比如：

data MyType Int Double String ()
  deriving Generic

它将有如下表示（目前隐藏了一些不重要的细节）。

>>> import GHC.Generics

>>> :kind! Rep MyType
(Rec0 Int :*: Rec0 Double) :*: (Rec0 String :*: Rec0 ())

>>> from (MyType 1 2.0 "a" ())
(K1 1 :*: K1 2.0) :*: (K1 "a" :*: K1 ())

>>> :kind! Rep ()
U1

>>> from ()
U1

所以，乘积类型被表示为一棵树，:*:s，而:+: 同样被用于总和类型。这些树被自动平衡，这很好，因为这将允许具有更好的平均案例复杂性的getters和setters。

现在，我们想用泛型来实现IsoValue 。按照书上的说法，我们定义了一个类型类，用于遍历一个类型的泛型表示：

class GIsoValue (x :: Type -> Type) where
  type GToT x :: T
  gToVal :: x p -> Val t
  gFromVal :: Val t -> x p

然后，我们描述这个表示法是如何与迈克尔逊基元关联的：

-- | Product type.
-- Each node in generic's binary tree corresponds to "pair" type
-- in Michelson.
instance (GIsoValue x, GIsoValue y) => GIsoValue (x :*: y) where
  type GToT (x :*: y) = 'TPair (GToT x) (GToT y)
  gToVal (x :*: y) = VPair (gToVal x) (gToVal y)
  gFromVal (VPair x y) = gFromVal x :*: gFromVal y

-- | Sum type.
instance (GIsoValue x, GIsoValue y) => GIsoValue (x :+: y) where
  type GToT (x :+: y) = 'TOr (GToT x) (GToT y)
  gToVal = VOr . \case
    L1 x -> VOr (Left $ gToVal x)
    R1 y -> VOr (Right $ gToVal y)
  gFromVal (VOr e) = case e of
    Left x -> L1 (gFromVal x)
    Right y -> R1 (gFromVal y)

-- | Unit type.
instance GIsoValue U1 where
  type GToT U1 = 'TUnit
  gToVal U1 = VUnit
  gFromVal VUnit = U1

-- | Leaf in tree.
-- Here we delegate to inner 'IsoValue', not 'GIsoValue', because user
-- may want to have a custom 'IsoValue' definition for his inner type.
instance IsoValue a => GIsoValue (Rec0 a) where
  type GToT (Rec0 a) = ToT a
  gToVal (K1 a) = toVal a
  gFromVal a = K1 (fromVal a)

-- | Wrappers with meta information which we don't care about.
instance GIsoValue x => GIsoValue (M1 t i x) where
  type GToT (M1 t i x) = GToT x
  gToVal = gToVal . unM1
  gFromVal = M1 . gFromVal

Void 和没有居住的类似类型还不能在Michelson中表示，所以我们定义了一个假的实例，在尝试使用时提示这个事实（这样，我们覆盖了默认的 "不能推导实例 "的错误）：

instance TypeError ('Text "Michelson forbids void-like types") =>
         GIsoValue V1 where
  type GToT V1 = TypeError ('Text "Attempt to use void-like type")
  gToVal = error "impossible"
  gFromVal = error "impossible"

注意：只有在写这篇文章的时候，空类型才能在Michelson中得到体现，这个功能可能已经发布了，请看Tezos的官方仓库。

在大多数情况下，在为一个数据类型编写IsoValue 实例时，人们可能希望使用这些推导规则。

因此，我们希望将GIsoValue 作为IsoValue 的默认实现：

import qualified Generic as G

class IsoValue a where
  type ToT a :: T
  type ToT a = GToT (G.Rep a)

  toVal :: a -> Val (ToT a)
  default toVal
    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GToT (G.Rep a))
    => a -> Val (ToT a)
  toVal = gToVal . G.from

  fromVal :: Val (ToT a) -> a
  default fromVal
    :: (Generic a, GIsoValue (G.Rep a), ToT a ~ GToT (G.Rep a))
    => Value (ToT a) -> a
  fromVal = G.to . gFromVal

现在，一个合同的开发者可以这样写：

{-# LANGUAGE DerivingStrategies #-}

data MyType
  = Ctor1 Integer Natural
  | Ctor2
  deriving stock Generic
  deriving anyclass IsoValue

-- This type ^ will be represented as "or (pair int nat) unit" 
-- in Michelson.

put1 :: s :-> MyType : s
put1 = push (Ctor1 1 2)  -- translates to "PUSH (Left (Pair 1 2))"

put2 :: s :-> MyType : s
put2 = push Ctor2  -- translates to "PUSH (Right Unit)"

用于处理对象的宏

问题

Lorentz变得非常有用的地方之一是处理用户定义类型的方法。

在开始使用我们的第一个真正的生产合约时，我们很害怕必须要写这样的代码：

type Storage = Storage
  { admin :: Address
  , paused :: Bool
  , proxy :: Address
  , totalSupply :: Natural
  , participantsNum :: Natural
  }

someMethod = do
  stackType @[Storage]

  -- get admin field
  dup; cdr; car            -- <- sad
  sender; assertEq ...

  -- get proxy field
  dup; cdr; cdr; cdr; car  -- <- even more sad
  not; assertEq ...

编写这样的代码是不方便的，但这种不方便几乎无法与修改成本相关的痛苦相提并论，例如，当一个人需要在其存储中添加一个新的字段时。我们想把建立cars和cdrs的确切序列的负担放在我们的eDSL上，就像许多其他超过Michelson的高级语言作为其提供的功能集的一部分那样。

实施例子

让我们看看最简单的方法--字段getter--是如何实现的。

我们需要一个函数，它接受一个字段名，并返回一条指令，从一个数据类型中获取相应的字段。

由于字段的存在和它的类型应该在编译时被检查，我们希望调用者在类型层而不是术语层提供字段的名字。

所以，我们的方法应该是这样的：

-- We will use Label from vinyl package
-- (<https://hackage.haskell.org/package/vinyl>).
-- Though it is easy to implement your own if extra dependencies
-- are undesired.
import Data.Vinyl.Derived (Label)

toField :: (...) => Label name -> (dt : s :-> GetFieldType dt name : s)
toField = undefined

由于有了这个 OverloadedLabels扩展，Label name 参数可以使用#myField 语法进行初始化，所以字段的名称对调用者来说将是非常方便的。

现在，如何实现呢？

当使用vanilla Generics时，正如上面所显示的，通常会有一个类型类来遍历一个类型的泛型表示，从而渐进地建立所需的指令。但是在这样的情况下，有一个类型类是不够的。

在这里，我们事先不知道在哪里翻阅泛型树以找到所需的字段；在这个意义上，封闭的类型族更加灵活，因为它们可以执行复杂的类型级计算。

因此，构建我们的getter宏要分两步进行：

  1. 使用类型族，在泛型表示法中构建一条通往所需字段的路径（Ls和Rs的序列）。如果没有找到所要求的字段，返回TypeError 。

之前，我们有意给出了一个不完整的通用基元列表；当然，它们包括字段名和其他信息，我们可以在查询中使用。

  1. 有一个类型类，按照返回的路径在数据类型上下降，并建立相应的CAR 和CDR 指令序列。

在第一阶段之后，我们应该在类型层面得到以下结构：

-- | Result of field lookup — its type and path to it in the tree.
data LookupNamedResult = LNR Type Path

-- | Path to a leaf (field) in the generic tree representation.
type Path = [Branch]

-- | Which branch to choose in generic tree representation.
data Branch = L | R

实现字段查找需要适量的代码。如果读者有兴趣的话，可以在下面找到：

字段查找的实现

-- Getters
type family LnrFieldType (lnr :: LookupNamedResult) where
  LnrFieldType ('LNR f _) = f
type family LnrBranch (lnr :: LookupNamedResult) :: Path where
  LnrBranch ('LNR _ p) = p

-- | Find a field of some product type by its name.
type GetNamed name a = LNRequireFound name a (GLookupNamed name (G.Rep a))

-- Lookup logic
type family GLookupNamed (name :: Symbol) (x :: Type -> Type)
          :: Maybe LookupNamedResult where
  GLookupNamed name (G.D1 _ x) = GLookupNamed name x
  GLookupNamed name (G.C1 _ x) = GLookupNamed name x

  GLookupNamed name (G.S1 ('G.MetaSel ('Just recName) _ _ _) (G.Rec0 a)) =
    If (name == recName)
      ('Just $ 'LNR a '[])
      'Nothing
  GLookupNamed name (G.S1 _ (G.Rec0 (NamedF f a fieldName))) =
    If (name == fieldName)
      ('Just $ 'LNR (NamedInner (NamedF f a fieldName)) '[])
      'Nothing
  GLookupNamed _ (G.S1 _ _) = 'Nothing

  GLookupNamed name (x :*: y) =
    LNMergeFound name (GLookupNamed name x) (GLookupNamed name y)
  GLookupNamed name (_ :+: _) = TypeError
    ('Text "Cannot seek for a field " ':<>: 'ShowType name ':<>:
     'Text " in sum type")
  GLookupNamed _ G.U1 = 'Nothing
  GLookupNamed _ G.V1 = TypeError
    ('Text "Cannot access fields of void-like type")

-- Helpers for merging results got in recursion
type family LNMergeFound
  (name :: Symbol)
  (f1 :: Maybe LookupNamedResult)
  (f2 :: Maybe LookupNamedResult)
    :: Maybe LookupNamedResult where
  LNMergeFound _ 'Nothing 'Nothing = 'Nothing
  LNMergeFound _ ('Just ('LNR a p)) 'Nothing = 'Just $ 'LNR a ('L ': p)
  LNMergeFound _ 'Nothing ('Just ('LNR a p)) = 'Just $ 'LNR a ('R ': p)
  LNMergeFound name ('Just _) ('Just _) = TypeError
    ('Text "Ambigous reference to datatype field: " ':<>: 'ShowType name)

-- Force result of 'GLookupNamed' to be 'Just'
type family LNRequireFound
  (name :: Symbol)
  (a :: Type)
  (mf :: Maybe LookupNamedResult)
    :: LookupNamedResult where
  LNRequireFound _ _ ('Just lnr) = lnr
  LNRequireFound name a 'Nothing = TypeError
    ('Text "Datatype " ':<>: 'ShowType a ':<>:
     'Text " has no field " ':<>: 'ShowType name)

在评估了字段的确切位置后，必要的宏可以通过专门的类型类来递归构建：

-- | Generic traversal for constructing 'toField' macro for
-- a specific field.
class GIsoValue x =>
  GToField
    (name :: Symbol)
    (x :: Type -> Type)
    (path :: Path)
    (fieldTy :: Type) where

  -- | Gets a field from the given part of the datatype.
  -- Note that here we work at Michelson level, not at Lorentz,
  -- because we need access to the underlying tree-of-pairs
  -- representation.
  gToField
    :: GIsoValue x
    => Instr (GToT x ': s) (ToT fieldTy ': s)

-- | Skipping wrappers with meta info in generic representation.
instance GToField name x path f =>
	           GToField name (G.M1 t i x) path f where
  gToField = gToField @name @x @path @f

-- | Recursion base.
instance (IsoValue f) =>
          GToField name (G.Rec0 f) '[] f where
  gToField = Nop

-- | Go-left case.
instance (GToField name x path f, GIsoValue y) =>
	  GToField name (x :*: y) ('L ': path) f where
  gToField = CAR `Seq` gToField @name @x @path @f

-- | Go-right case.
instance (GToField name y path f, GIsoValue x) =>
	  GToField name (x :*: y) ('R ': path) f where
  gToField = CDR `Seq` gToField @name @y @path @f

-- | Ready macro for accessing given field of the given datatype.
toField
  :: forall dt name s.
     (InstrGetFieldC dt name)
  => Label name -> (dt : s) :-> (GetFieldType dt name : s)
toField _ = I $
  gToField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))
	   @(GetFieldType dt name)

-- | Constraint for `toField'.
type InstrGetFieldC dt name =
  ( Generic t, IsoValue t, ToT t ~ GValueType (G.Rep t)
  , GToField name (G.Rep dt)
      (LnrBranch (GetNamed name dt))
      (LnrFieldType (GetNamed name dt))
  )

请注意，这次我们并没有为所有的泛型基元提供实例--有些情况是无法通过构造通向字段的路径实现的。相反，我们主要需要确保路径上的模式匹配是完整的，也就是说，[] 、L : path' 和R : path' 的情况（再加上一个带有M1 通用包装的情况）都被考虑了。

做完这些工作后，合同开发人员可以按以下方式编写代码：

someMethod = do
  stackType @[Storage]

  dup; toField #admin  -- no more car's and cdr's
  sender; assertEq ...

  dup; toField #paused
  not; assertEq ...

其他方法

所有用于处理数据类型的洛伦兹方法包括：

-- * For product types
toField
getField      -- dup + toField
setField
modifyField
construct     -- makes up an object from scratch

-- * For sum types
wrap          -- wrap a value into constructor
unwrapUnsafe  -- unwrap value expecting the given constructor,
              -- fail otherwise
case

在试图使与和类型一起工作的方法也接受标签时，有一个意想不到的障碍。我们想在那里指定的构造函数名称总是以大写字母开始，然而，标签不能以它们开始。我们看到有两种方法可以解决这个问题--要么通过类型应用接受构造函数名称（@"MyConstructor" ），要么期望构造函数名称以小写字母为前缀。最终，我们选择了c （用于构造函数）前缀，如#cMyConstructor 。

最后一个挑战是如何在语法和语义上合理地定义case 。我们不能在这里使用Haskell的case ，因为它与我们想要的有很大差别。

最后，我们想出了以下的语法：

myMethod =
  caseT
    ( #cConstructor1 /-> do
        stackType @(FieldOfConstructor1 : _)
        ...

    , #cConstructor2 /-> do
        ...
    )

在caseT 中指定构造函数的名称并不是严格必要的（可以一直使用fromLabel ），我们这样做只是为了增加代码的可读性。正如caseT 的名字所暗示的，这个方法接受一个元组；对于其他可能的接口，调用者很可能需要将大小写条款放在括号里，这将是很不方便的。

缺点

使用泛型的方法有几个很大的缺点。

错误信息

在目前（我们在写作时使用的是GHC-8.8），似乎无法控制约束条件的检查顺序。

有了泛型，人们经常要用约束条件来声明函数，比如：

myFunc :: (Generic a, SomeConstraint (G.Rep a)) => ...

如果用户忘记为他的数据类型声明Generic 实例，那么就很难预测哪个约束会被触发--第一个，第二个，甚至是两个。 而且没有简单的方法来影响这个。

考虑到后一个约束可能会产生很大的结果，这一点尤其令人难过；当Generic 实例没有被定义时，编译器无法推理出G.Rep a ，并跳出它无法推理的整个约束，这对于不太熟悉Haskell的用户来说是相当混乱的。根据我们的经验，甚至有些开发人员花了一个小时或更多的时间来理解错误的来源，在弄清楚之后，只是学会了一个规则 "大错误=>任何通用实例被遗忘？"，这确实是一个不是最好用户体验的标志。

解决这个问题的方法之一是把卡住的类型族推理变成一个类型错误，就像这篇文章中描述的那样。 例如，该 generic-lens这仍然需要库的开发者做一些额外的努力和特别的照顾。

编译时间

编译一个有大量数据类型和宏的合同可能需要相当多的内存和CPU时间，尽管根据我们的经验，它可以被控制在合理的范围内。

让我们首先注意到，我们用-O0 标志来构建项目，因为在Michelson核心中使用单子已经对编译时间产生了很大的影响。这不是一个大问题，因为在运行时，优化标志只影响从洛伦兹到Michelson的转换速度，而这是相当低的。

我们最大的项目使用了大约8Gb和2-3分钟的时间来编译Intel® Core™ i7-7700HQ CPU @ 2.80GHz, SSD with-j4 or-j0 ，尽管那里的合同包含了相当多的商业逻辑（一些终端几乎不适合Tezos的800k硬气体限制）。中等规模的合同并没有消耗任何大量的资源。

锅炉板

用vanillaGHC.Generic 实现新的功能可能很繁琐，因为它涉及到编写大量的实例，而且用它重用逻辑也相对困难。我们选择了它，因为它自动提供了和与积类型的平衡，并且在用户方面几乎不需要模板，尽管现在Lorentz已经变得相当大，可能值得切换到其他东西。

替代方案

泛型SOP

generics-sop包允许不以二进制树的形式来表示数据类型，而是以字段列表的形式来表示，并定义了许多方便的实用程序来处理这种表示。也许对于将数据类型转换为 Michelson 并不完全方便（需要手动平衡），但对于其他 Lorentz 特性来说却很方便，我们将在接下来的文章中介绍。

Template Haskell

一个完全不同的方法是使用Template Haskell来分析数据类型，并生成必要的类型级声明（用于麦科尔森表示法）、方法和类型实例（用于宏）。由于Haskell AST很大，所以工作起来可能稍微有点困难，但是在术语层面上的生成逻辑可以更好地重用和控制错误。

总结

在这篇文章中，我们考虑了在Lorentz中实现复杂对象和各自的宏。所产生的功能与其他高级语言（如Michelson）所提供的功能相似。

对象的整体实现可以在Morley资源库中找到。它还包含了几个使用这个功能的公共合同。

在下面的文章中，我们将考虑Haskell的newtypes如何有利于确保洛伦兹契约的正确性。

avatar
文章
阅读
粉丝