On Vox: О закрытых классах - 2

[migmit]

Как обычно, стоило записать мысль, и появилось понимание, почему она не нужна.

> {-# LANGUAGE GADTs, RankNTypes #-}
> module Derive where
> import Control.Monad
> import Control.Monad.Reader
> import Control.Monad.State

Итак, начинаем с того же фруктового примера.

> data Apple = Apple deriving Show
> data Orange = Orange deriving Show

Вместо forall используем те же GADT-ы:

> data FruitD a where
>     FruitApple :: FruitD Apple
>     FruitOrange :: FruitD Orange
> class Fruit a where fruit :: FruitD a

Маленький недостаток: приходится заводить пару лишних имён. Ну, что поделаешь - надо так надо.

> instance Fruit Apple where fruit = FruitApple
> instance Fruit Orange where fruit = FruitOrange

Используем, опять же, для вывода Show:

> data ShowEv a where ShowEv :: Show a => ShowEv a
> showD :: ShowEv a -> a -> String
> showD ShowEv = show

При таком подходе нужно давать аннотации типов, иначе GADT-ы отказываются паттерн-матчится. Для этого, в свою очередь, приходится заводить вспомогательную функцию:

> showFruit :: Fruit a => ShowEv a
> showFruit = showFruit' fruit where
>     showFruit' :: FruitD a -> ShowEv a
>     showFruit' FruitApple = ShowEv
>     showFruit' FruitOrange = ShowEv

Зато паттерн-матчинг действительно пишется как паттерн-матчинг.

Точно также делается для рекурсивных типов:

> data IntNil = IntNil deriving Show
> data IntCons t = IntCons Integer t deriving Show
> intVectorExample :: IntCons (IntCons (IntCons IntNil))
> intVectorExample = IntCons 3 $ IntCons 1 $ IntCons 4 $ IntNil

Причём в этом случае вполне разумно, мне кажется, рекурсивно перекрутить класс и тип.

> data IntVectorD t where
>     IntVectorNil :: IntVectorD IntNil
>     IntVectorCons :: IntVector t => IntVectorD (IntCons t) -- обратите внимание на указанное ограничение в виде класса
> class IntVector t where intVector :: IntVectorD t
> instance IntVector IntNil where intVector = IntVectorNil
> instance IntVector t => IntVector (IntCons t) where intVector = IntVectorCons
> showIntVector :: IntVector v => ShowEv v
> showIntVector = showIntVector' intVector where
>     showIntVector' :: IntVectorD t -> ShowEv t
>     showIntVector' IntVectorNil = ShowEv
>     showIntVector' IntVectorCons = showEvCons showIntVector -- а вот сюда переезжает рекурсия
>     showEvCons :: ShowEv t -> ShowEv (IntCons t)
>     showEvCons ShowEv = ShowEv

Абсолютно аналогичным образом делается и для типов высших порядков:

> data StateOrReaderD m where
>     StateOrReaderState :: StateOrReaderD State
>     StateOrReaderReader :: StateOrReaderD Reader
> class StateOrReader m where stateOrReader :: StateOrReaderD m
> instance StateOrReader State where stateOrReader = StateOrReaderState
> instance StateOrReader Reader where stateOrReader = StateOrReaderReader

Для них точно таким же способом выводятся инстансы:

> data MonadEv m where MonadEv :: Monad m => MonadEv m
> returnD :: MonadEv m -> x -> m x
> returnD MonadEv = return
> bindD :: MonadEv m -> m x -> (x -> m y) -> m y
> bindD MonadEv mx h = mx >>= h

Причём вспомогательный тип становится не нужен:

> -- newtype MonadSORHelper a m = MonadSORHelper (MonadEv (m a))
> monadStateOrReader :: StateOrReader m => MonadEv (m a)
> monadStateOrReader = monadStateOrReader' stateOrReader where
>     monadStateOrReader' :: StateOrReaderD t -> MonadEv (t a)
>     monadStateOrReader' StateOrReaderState = MonadEv
>     monadStateOrReader' StateOrReaderReader = MonadEv

Для функций, не входящих в классы, вспомогательный тип тоже не нужен:

> -- newtype GetSORHelper a x m = GetSORHelper (m a x)
> genericGet :: StateOrReader m => m a a
> genericGet = genericGet' stateOrReader where
>     genericGet' :: StateOrReaderD t -> t a a
>     genericGet' StateOrReaderState = get
>     genericGet' StateOrReaderReader = ask

Ну и, для полноты картины, рекурсивные типы высших порядков работают ничем не хуже:

> data Nil a = Nil a deriving Show
> data Cons t a = Cons a (t a) deriving Show
> data VectorD t where
>     VectorNil :: VectorD Nil
>     VectorCons :: Vector t => VectorD (Cons t)
> class Vector t where vector :: VectorD t
> instance Vector Nil where vector = VectorNil
> instance Vector t => Vector (Cons t) where vector = VectorCons
> newtype ShowVectorHelper t = ShowVectorHelper {showVectorHelper :: Show a => ShowEv (t a)}
> showVector :: (Vector v, Show a) => ShowEv (v a)
> showVector = showVector' vector where
>     showVector' :: Show a => VectorD t -> ShowEv (t a)
>     showVector' VectorNil = ShowEv
>     showVector' VectorCons = showEvCons showVector
>     showEvCons :: Show a => ShowEv (v a) -> ShowEv (Cons v a)
>     showEvCons ShowEv = ShowEv

Вот. Буду теперь пользоваться этим. Для тех, кто пользуется другими компиляторами, не поддерживающими GADT-ы, всё ещё остаётся подход из предыдущего поста.

Originally posted on migmit.vox.com