Comment fabriquer des lentilles pour les enregistrements de type-familles

Question

Voici ce que j'ai, qui n'est pas la compilation:

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

Erreur de compilation:

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

Le problème ici est que makeLensesFor va essayer pour générer une instance comme suit:

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

Ceci, cependant, est une erreur car vous ne pouvez pas créer une instance. pour le résultat d'une application de type famille. Pour éviter cela, nous pouvons écrire l'instance manuellement pour chacun des deux choix possibles pour 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