Линзы и TypeFamilies

Question

Я столкнулся с проблемой использования Control.Lens вместе с
типы данных при использовании -XTypeFamilies GHC Pragma.

{-# 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?

Answer 1

Самым разумным было бы просто определить эти линзы самостоятельно... это не так сложно:

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₀

... который вообще ничего не использует из библиотеки линз, но полностью совместим со всеми комбинаторами линз.

Answer 2

tfMakeLenses генерирует сеттеры типа t a -> a -> t a для связанных типов данных.
В некоторых местах эту функцию можно улучшить, но она работает!

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

Answer 3

Этот ответ является адаптацией исходного ответа errfrom с немного более подробной информацией. Функция ниже также создает линзы, а не просто сеттеры.

создает линзы типа Lens' s a, или по определению (a -> f a) -> s -> f s для связанных типов данных.

      {-# 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