Как получить экземпляры для записей с типовыми семьями

Question

Вот что я пытаюсь, но он не компилируется:

{-# LANGUAGE TypeFamilies #-} 
{-# LANGUAGE StandaloneDeriving #-} 
{-# LANGUAGE FlexibleInstances #-} 

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

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 
    } 

deriving instance (Show baseType) => Show (Incoming Validated baseType) 
deriving instance (Show baseType) => Show (Incoming ValidationErrors baseType) 

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

23 38 error   error: 
• Illegal type synonym family application in instance: 
    Incoming Validated baseType 
• In the stand-alone deriving instance for 
    ‘(Show baseType) => Show (Incoming Validated baseType)’ (intero) 
24 38 error   error: 
• Illegal type synonym family application in instance: 
    Incoming ValidationErrors baseType 
• In the stand-alone deriving instance for 
    ‘(Show baseType) => Show (Incoming ValidationErrors baseType)’ (intero) 

Answer 1

У вас есть две проблем здесь. Первый - это то, что GHC говорит вам. В принципе, вы не можете иметь экземпляр, который зависит от семейства типов (тип семейства может быть там, но только если все аргументы, которые он получает, являются конкретными типами). Всевозможные плохие вещи могут начаться после того, как вы разрешите это, не в последнюю очередь из того, что правая сторона вашего типа может иметь обращения к другим типам семейств.

В целом, можно решить такую ​​проблему, переместив семейного типа приложения к ограничению:

deriving instance (Show baseType, i ~ Incoming Validated baseType) => Show i 
deriving instance (Show baseType, i ~ Incoming ValidationErrors baseType) => Show i 

Делать это на самом деле делает вторую проблему очевидной: ваш экземпляр головы являются слишком общими.

Тем не менее, я не уверен, что есть что-то, что можно исправить - просто избавитесь от линий вывода. Вы хотели бы, чтобы первый задумался: вывести экземпляр Show basetype с учетом ограничения Show basetype (что совершенно бессмысленно). Второй вариант одинаково бессмыслен - у Either уже есть экземпляр Show.

Answer 2

Это не может быть сделано для работы. Вот проблема:

Incoming Validated  (Either [T.Text] Int) ~ Either [T.Text] Int 
Incoming ValidationErrors Int     ~ Either [T.Text] Int 

Теперь, если вы хотите Show (Either [T.Text] Int), у вас есть три варианта:

instance (Show a, Show b) => Show (Either a b) -- from Prelude 
instance Show baseType => Show (Incoming Validated baseType) 
instance Show baseType => Show (Incoming ValidationErrors baseType) 

Любой из них будет действующий экземпляр, и GHC требует глобальной уникальности экземпляров. Действительно, проблема в том, что типы семейств не являются инъективными, и поэтому только потому, что вы знаете, что вам нужен instance TyCls A, GHC не может создать приложение TyFam B1 B2 B3, которое создаст A - такое приложение может быть даже не уникальным!

---

Есть несколько способов исправить это.

1. Вам действительно нужен экземпляр Show? Возможно, все, что вам нужно, - это ограничение Showограничения функций на функции, которые его хотят использовать. Так, например:

   {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} 
   -- But not FlexibleInstances 
   
   deriving instance (Show (Incoming f Int64), Show (Incoming f Tag)) 
       => Show (NewTag f) 
   

   GHC будут распространяться эти ограничения во всем мире, но они всегда выполнимой конечным пользователем. И если f - это конкретный тип, они полностью исчезнут!

2. Вы действительно хотите, чтобы Incoming вещи были неотличимы от базовых типов? Если нет, то вы могли бы использовать GADT здесь:

   {-# LANGUAGE GADTs, FlexibleInstances #-} 
   
   -- ... 
   
   data Incoming :: * -> * -> * where 
       IncomingValidated  :: baseType 
             -> Incoming Validated baseType 
       IncomingValidationErrors :: Either [T.Text] baseType 
             -> Incoming ValidationErrors baseType 
   
   -- ... 
   
   deriving instance Show (NewTag Validated) 
   deriving instance Show (NewTag ValidationErrors) 
   

Минус здесь двоякий: во-первых, вы должны шаблон матч везде использовать их; во-вторых, вы не можете (на GHC 7.10, по крайней мере) используют StandaloneDeriving для экземпляров GADT Show, вам нужно написать их вручную:

-- deriving instance Show baseType => Show (Incoming Validated baseType) 
    instance Show baseType => Show (Incoming Validated baseType) where 
     show (IncomingValidated bt) = "IncomingValidated " ++ show bt 

    -- deriving instance Show baseType => Show (Incoming ValidationErrors baseType) 
    instance Show baseType => Show (Incoming ValidationErrors baseType) where 
     show (IncomingValidationErrors e) = "IncomingValidationErrors " ++ show e 

Любой из них может быть хорошим решением; Параметр (1) - это наименьшее изменение от того, что вы уже делаете, и поэтому, вероятно, я буду первым.

---

Еще одно замечание: в современных (7.10+) GHC мы можем что-то убрать в вашем коде. Прямо сейчас у вас есть два места, которые ваш код допускает слишком большую гибкость.

1. Вы можете рассмотреть значение типа NewTag Bool или NewTag(), или ....
2. Семейство Incoming - это open - любой может добавить type instance Incoming Bool baseType = Maybe baseType, или Incoming()() = Int, или ....

Вы только хотите рассмотреть Validated или ValidationErrors там, и вы уже написали все возможные случаи семейного типа! GHC предоставляет две функции для улучшения этого: DataKinds и семейства закрытого типа. С семьями закрытого типа, вы можете написать

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

Теперь это закрыт - никто никогда не может добавить новый случай. Это решает # 2.

Что касается №1, если мы включим DataKinds, GHC автоматически продвигает наши конструкторы значений до уровня уровня! Так как у нас есть Int :: *, у нас есть 'False :: Bool - ' указывает GHC, что мы находимся на уровне уровня. Добавление этой функции выглядит следующим образом:

{-# LANGUAGE DataKinds #-} 

-- ... 

data ValidationResult = Validated | ValidationErrors 
         deriving (Eq, Ord, Enum, Bounded, Show, Read) 

---- EITHER: 
---- Option (1), with a type family 
-- The only change here is to add tick marks! 
type family Incoming validationResult baseType where 
    Incoming 'Validated  baseType = baseType 
    Incoming 'ValidationErrors baseType = Either [T.Text] baseType 

---- OR: 
---- Option (2), with a GADT 
-- Here, we change the kind signature and add tick marks 
data Incoming :: ValidationResult -> * -> * where 
    IncomingValidated  :: baseType 
          -> Incoming 'Validated baseType 
    IncomingValidationErrors :: Either [T.Text] baseType 
          -> Incoming 'ValidationErrors baseType 

Мы можем также добавить добрые подписи, если мы хотим, - type family Incoming (validationResult :: ValidationResult) (baseType :: *) :: * where … или data NewTag (f :: ValidationResult) = …, но те будут судить, и, следовательно, являются необязательными.

Если клещ действительно вас раздражает, вы можете использовать следующий трюк, который я взял из исходного кода GHC:

type Validated  = 'Validated 
type ValidationErrors = 'ValidationErrors 

---

ОК, еще один тип уровня забавная вещь, потому что я не могу сопротивляться :-) Давайте рассмотрим вариант (1) снова, с типом семейства. Мы должны обеспечить это раздражающее ограничение (Show (Incoming f Int64), Show (Incoming f Tag)) везде, которое является довольно громоздким, особенно если мы хотим абстрагироваться над ним - для создания экземпляра Eq, это то же самое, но с Eq вместо Show. А что, если есть больше полей?

Если мы включили ConstraintKinds, мы сможем связаться с нами can аннотация с ограничениями. Это работает так:

{-# LANGUAGE ConstraintKinds #-} 

import GHC.Exts (Constraint) 

type NewTagFieldsAre (c :: * -> Constraint) f = 
    (c (Incoming f Int64), c (Incoming f Tag)) 

(Нам нужна такая подпись так GHC не думаю, что это производит обычный кортеж.) Затем мы можем указать

deriving instance NewTagFieldsAre Eq f => Eq (NewTag f) 
deriving instance NewTagFieldsAre Ord f => Ord (NewTag f) 
deriving instance NewTagFieldsAre Show f => Show (NewTag f) 
deriving instance NewTagFieldsAre Read f => Read (NewTag f) 

И все намного короче!

---

Составляя это все вместе, вот какой вариант (1) выглядит с типом семейства. Единственное, что отличается от этого, это то, что я укрепил изменения, которые я сделал, немного переформатировал и сделал несколько других изменений на основе вкуса.

{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, 
      ConstraintKinds, DataKinds, StandaloneDeriving #-} 

import Data.Text as T 
import Data.Int (Int64) 
import GHC.Exts (Constraint) 

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

data ValidationResult = Validated | ValidationErrors 
         deriving (Eq, Ord, Enum, Bounded, Show, Read) 

type family Incoming (vres :: ValidationResult) (base :: *) :: * where 
    Incoming 'Validated  base = base 
    Incoming 'ValidationErrors base = Either [T.Text] base 

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

type NewTagFieldsAre (c :: * -> Constraint) f = 
    (c (Incoming f Int64), c (Incoming f Tag)) 

deriving instance NewTagFieldsAre Eq f => Eq (NewTag f) 
deriving instance NewTagFieldsAre Ord f => Ord (NewTag f) 
deriving instance NewTagFieldsAre Show f => Show (NewTag f) 
deriving instance NewTagFieldsAre Read f => Read (NewTag f) 

И для полноты картины, опция GADT:

{-# LANGUAGE GADTs, FlexibleInstances, TypeFamilies, DataKinds, 
      StandaloneDeriving #-} 

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

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

data ValidationResult = Validated | ValidationErrors 
         deriving (Eq, Ord, Enum, Bounded, Show, Read) 

data Incoming :: ValidationResult -> * -> * where 
    IncomingValidated  :: base 
          -> Incoming Validated base 
    IncomingValidationErrors :: Either [T.Text] base 
          -> Incoming ValidationErrors base 

instance Eq base => Eq (Incoming Validated base) where 
    IncomingValidated x == IncomingValidated y = x == y 

instance Eq base => Eq (Incoming ValidationErrors base) where 
    IncomingValidationErrors ex == IncomingValidationErrors ey = ex == ey 

instance Ord base => Ord (Incoming Validated base) where 
    IncomingValidated x `compare` IncomingValidated y = x `compare` y 

instance Ord base => Ord (Incoming ValidationErrors base) where 
    IncomingValidationErrors ex `compare` IncomingValidationErrors ey = ex `compare` ey 

instance Show base => Show (Incoming Validated base) where 
    show (IncomingValidated x) = "IncomingValidated " ++ show x 

instance Show base => Show (Incoming ValidationErrors base) where 
    show (IncomingValidationErrors ex) = "IncomingValidationErrors " ++ show ex 

-- `Show` properly handling precedence, along with the `Read` instance, are left 
-- as an exercise for the interested reader. 

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

deriving instance Eq (NewTag Validated) 
deriving instance Eq (NewTag ValidationErrors) 
deriving instance Ord (NewTag Validated) 
deriving instance Ord (NewTag ValidationErrors) 
deriving instance Show (NewTag Validated) 
deriving instance Show (NewTag ValidationErrors) 

Это необходимо вручную вывести экземпляры действительно перетащить его вниз!