[英]Lenses and TypeFamilies
我遇到了一起使用Control.Lens
的问题
使用-XTypeFamilies
GHC 编译指示时的数据类型。
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Lens (makeLenses)
class SomeClass t where
data SomeData t :: * -> *
data MyData = MyData Int
instance SomeClass MyData where
data SomeData MyData a = SomeData {_a :: a, _b :: a}
makeLenses ''SomeData
错误信息是: reifyDatatype: Use a value constructor to reify a data family instance
。
有什么办法可以克服它,也许使用Control.Lens
一些功能?
最明智的做法是自己定义这些镜头……这并不难:
a, b :: Lens' (SomeData MyData a) a
a = lens _a (\s a' -> s{_a=a'})
b = lens _b (\s b' -> s{_b=b'})
甚至
a, b :: Functor f => (a -> f a) -> SomeData MyData a -> f (SomeData MyData a)
a f (SomeData a₀ b₀) = (`SomeData`b₀) <$> f a₀
b f (SomeData a₀ b₀) = SomeData a₀ <$> f b₀
...它根本不使用镜头库中的任何内容,但与所有镜头组合器完全兼容。
tfMakeLenses
为关联的数据类型生成ta -> a -> ta
类型的 setter。
这个功能有一些地方可以改进,但它有效!
tfMakeLenses :: Name -> DecsQ
tfMakeLenses t = do
fieldNames <- tfFieldNames t
let associatedFunNames = associateFunNames fieldNames
return (map createLens associatedFunNames)
where createLens :: (Name, Name) -> Dec
createLens (funName, fieldName) =
let dtVar = mkName "dt"
valVar = mkName "newValue"
body = NormalB (LamE [VarP valVar] (RecUpdE (VarE dtVar) [(fieldName, VarE valVar)]))
in FunD funName [(Clause [VarP dtVar] body [])]
associateFunNames :: [Name] -> [(Name, Name)]
associateFunNames [] = []
associateFunNames (fieldName:xs) = ((mkName . tail . nameBase) fieldName, (mkName . nameBase) fieldName)
: associateFunNames xs
tfFieldNames t = do
FamilyI _ ((DataInstD _ _ _ _ ((RecC _ fields):_) _):_) <- reify t
let fieldNames = flip map fields $ \(name, _, _) -> name
return fieldNames
该答案是对 errfrom 原始答案的改编,其中包含更多细节。 下面的函数还创建镜头,而不仅仅是设置器。
tfMakeLenses
生成Lens' sa
类型的Lens' sa
,或者根据定义, (a -> fa) -> s -> fs
用于关联数据类型。
{-# TemplateHaskell #-}
import Control.Lens.TH
import Language.Haskell.TH.Syntax
tfMakeLenses typeFamilyName = do
fieldNames <- tfFieldNames typeFamilyName
let associatedFunNames = associateFunNames fieldNames
return $ map createLens associatedFunNames
where -- Creates a function of the form:
-- funName lensFun record = fmap (\newValue -> record {fieldName=newValue}) (lensFun (fieldName record))
createLens :: (Name, Name) -> Dec
createLens (funName, fieldName) =
let lensFun = mkName "lensFunction"
recordVar = mkName "record"
valVar = mkName "newValue"
setterFunction = LamE [VarP valVar] $ RecUpdE (VarE recordVar) [(fieldName, VarE valVar)]
getValue = AppE (VarE fieldName) (VarE recordVar)
body = NormalB (AppE (AppE (VarE 'fmap) setterFunction) (AppE (VarE lensFun) getValue))
in FunD funName [(Clause [VarP lensFun, VarP recordVar] body [])]
-- Maps [Module._field1, Module._field2] to [(field1, _field1), (field2, _field2)]
associateFunNames :: [Name] -> [(Name, Name)]
associateFunNames = map funNames
where funNames fieldName = ((mkName . tail . nameBase) fieldName, (mkName . nameBase) fieldName)
-- Retrieves fields of last instance declaration of type family "t"
tfFieldNames t = do
FamilyI _ ((DataInstD _ _ _ _ ((RecC _ fields):_) _):_) <- reify t
let fieldNames = flip map fields $ \(name, _, _) -> name
return fieldNames
用法:将类型系列名称传递给tfMakeLenses
。 镜头将在调用之前为最后一个类型系列实例创建。
class SomeClass t where
data SomeData t :: * -> *
data MyData = MyData Int
instance SomeClass MyData where
data SomeData MyData a = SomeData {_a :: a, _b :: a
tfMakeLenses ''SomeData
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.