产品总和的组合镜头和棱镜?

Combo lenses and prisms for sums of products?

如果我有唱片类型,我几乎可以用镜头做任何我想做的事情。如果我有求和类型,我几乎可以用棱镜做任何我想做的事情。但是,如果我有一个包含记录的总和,makeFields 不会让我了解这些领域(当然),而只会为他们提供遍历。 declarePrisms 似乎更有希望。根据文档,

declarePrisms [d|
  data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }
  |]

将创建

data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }
_Lit :: Prism' Exp Int
_Var :: Prism' Exp String
_Lambda :: Prism' Exp (String, Exp)

这让我快到了,但我真正想要的更像这样:

data Exp = Lit Int | Var String | Lambda String Exp
data LambdaRec = { _bound::String, _body::Exp }
...
_Lambda :: Prism' Exp LambdaRec
-- bound and body lenses into LambdaRec,
-- and ideally also traversals to look at them in Exp.
class MightBeLambda t where
  type BoundOptic t
  type BodyOptic t
  bound :: BoundOptic t
  body :: BodyOptic t
instance MightBeLambda Exp where
  type BoundOptic Exp = Traversal' Exp String
  ...
instance MightBeLambda LambdaRec where
  type BoundOptic LambdaRec = Lens' LambdaRec String

有什么方法可以自动完成这样的操作,还是我必须手动完成?


人们可能希望采用一种更疯狂的方式:

data ExpTag = LitT | VarT | LambdaT

data Exp' :: ExpTag -> * where
  Lit' :: Int -> Exp' LitT
  Var' :: String -> Exp' VarT
  Lambda' :: { _bound::String, _body::Exp } -> Exp' LambdaT

那么棱镜就可以恶毒的定义了,使用unsafeCoerce来规避任何复制记录的风险

您可以绕过另一个生成的 Iso 来获得此行为。 (当应用于具有单个构造函数的类型时,makePrisms 生成 Isos)

{-# LANGUAGE TemplateHaskell #-}

module Demo where

import Control.Lens

data Exp = Lit Int | Var String | Lambda String Exp
data LambdaRec = LambdaRec { _bound::String, _body::Exp }

makePrisms ''Exp
makePrisms ''LambdaRec
makeLenses ''LambdaRec

_ExpLambdaRec :: Prism' Exp LambdaRec
_ExpLambdaRec = _Lambda . from _LambdaRec

-- Example using _ExpLambdaRec
expBound :: Traversal' Exp String
expBound = _ExpLambdaRec . bound

请注意,由于 GHC 可以进行优化,因此生成的代码中不一定会使用此中间记录类型。

getBound :: Exp -> Maybe String
getBound = preview expBound

-- Generated core for getBound
--
-- getBound1 =
--   \ eta_B1 ->
--     case eta_B1 of _ {
--       __DEFAULT -> (Nothing) `cast` ...;
--       Lambda y1_a6XB y2_a6XC -> (Just y1_a6XB) `cast` ...
--     }