Как сделать линзы для записей с типовыми семьями

Question

Вот что у меня есть, что не компиляции:

{-# LANGUAGE TypeFamilies #-} 
{-# LANGUAGE StandaloneDeriving #-} 
{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE TemplateHaskell #-} 
{-# LANGUAGE MultiParamTypeClasses #-} 
{-# LANGUAGE FunctionalDependencies #-} 

import Data.Text as T 
import Data.Int (Int64) 
import Control.Lens 

type family Incoming validationResult baseType 
type instance Incoming Validated baseType = baseType 
type instance Incoming ValidationErrors baseType = Either [T.Text] baseType 

data Validated 
data ValidationErrors 

data Tag = Tag {unTag :: T.Text} deriving (Eq, Show) 

data NewTag f = NewTag 
    { 
    ntClientId :: Incoming f Int64 
    , ntTag :: Incoming f Tag 
    } 

$(makeLensesWith abbreviatedFields ''NewTag) 

Ошибка компиляция:

27 3 error   error: 
• Illegal type synonym family application in instance: 
    Incoming f_a1Kvx Int64 
• In the instance declaration for 
    ‘HasClientId (NewTag f_a1Kvx) (Incoming f_a1Kvx Int64)’ (intero) 
27 3 error   error: 
• Illegal type synonym family application in instance: 
    Incoming f_a1Kvx Tag 
• In the instance declaration for 
    ‘HasTag (NewTag f_a1Kvx) (Incoming f_a1Kvx Tag)’ (intero) 

Answer 1

Проблема здесь заключается в том, что makeLensesFor будет пытаться для создания экземпляра следующим образом:

instance HasClientId (NewTag f) (Incoming f Int64) where 
    .... 

Это, однако, ошибка, потому что вы не можете создать inst для результата типового семейства приложений. Чтобы избежать этого, мы можем написать экземпляр вручную для каждого из двух возможных вариантов для f:

-- generate lenses _foo for each record selector foo 
-- (in this case, generates _ntClientId and _ntTag lenses) 
makeLensesWith (lensRules & lensField .~ mappingNamer (\x -> ['_' : x])) ''NewTag 

class HasClientId s a | s -> a where 
    clientId :: Lens' s a 

instance HasClientId (NewTag Validated) Int64 where 
    clientId = _ntClientId 

instance HasClientId (NewTag ValidationErrors) (Either [T.Text] Int64) where 
    clientId f a = f (ntClientId a) <&> \ntClientId' -> a { ntClientId = ntClientId' } 

class HasTag s a | s -> a where 
    tag :: Lens' s a 

instance HasTag (NewTag Validated) Tag where 
    tag = _ntTag 

instance HasTag (NewTag ValidationErrors) (Either [T.Text] Tag) where 
    tag = _ntTag