On Vox: Ограниченное - часть 3

[migmit]

Всё изложенное ранее - очень хорошо, но относится к одному единственному классу - "Ord". Увы, мы не можем сделать класс параметром чего бы то ни было - тип можем, а вот класс - нет. Однако в Haskell-Café пробежало решение и этой проблемы.

Для этого решения требуются type families. Я вынесу в отдельный модуль как общий код, так и то, что нужно написать для "Set":

> {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}
> module Suitable where

Прагм многовато, но, за исключением первой, GHC подсказывает все остальные.

Мы используем "Set" для примера, так что импортируем соответствующий модуль:

> import qualified Data.Set as Set

Суть дела - в следующем классе; функция "constraints" не использует свой аргумент, ей нужен только его тип; все необходимые ограничения на тип "a" содержатся в типе "Constraints m a" - позднее мы увидим, как именно они задаются.

> class Suitable m a where
>     data Constraints m a :: *
>     constraints :: m a -> Constraints m a

Теперь можно ввести собственно "ограниченную монаду"

> class RestrMonad m where
>     restrReturn :: Suitable m a => a -> m a
>     restrBind :: (Suitable m a, Suitable m b) => m a -> (a -> m b) -> m b

и ограниченный вариант "MonadPlus":

> class RestrMonad m => RestrPlus m where
>     restrMZero :: Suitable m a => m a
>     restrMPlus :: Suitable m a => m a -> m a -> m a

Как и раньше, нам пригодится аналог функции "msum":

> restrMSum :: (RestrPlus m, Suitable m a) => [m a] -> m a
> restrMSum = foldr restrMPlus restrMZero

Теперь посмотрим, как это всё работает для "Set". Для начала - класс "Suitable".

> instance Ord a => Suitable Set.Set a where
>     data Constraints Set.Set a = Ord a => SetConstraints
>     constraints _ = SetConstraints

Как видим, и класс "Suitable" и тип "Constraints" определены лишь тогда, когда "a" относится к классу "Ord". Это и есть то ограничение, которое нам нужно. Функция "constraints" позволяет нам проверять это ограничение, как, например, в определении инстанса "RestrMonad"

> instance RestrMonad Set.Set where
>     restrReturn = Set.singleton
>     restrBind sx f = let result = case constraints result of SetConstraints -> Set.unions $ map f $ Set.toList sx in result

или инстанса "RestrPlus".

> instance RestrPlus Set.Set where
>     restrMZero = Set.empty
>     restrMPlus sx1 sx2 = case constraints sx1 of SetConstraints -> Set.union sx1 sx2

Теперь основной модуль выглядит ровно так же, как и раньше, только функции, начинающиеся на "ord" заменяются функциями, начинающимися на "restr".
> {-# LANGUAGE GADTs #-}
> module Restricted where
> import Control.Monad
> import Control.Monad.Identity
> import Control.Monad.List
> import Control.Monad.Trans
> import qualified Data.Set as Set
> import Suitable
>
> data RestrTData m n a where
>     RestrRet :: a -> RestrTData m n a
>     RestrBind :: Suitable m a => m a -> (a -> RestrT m n b) -> RestrTData m n b
> newtype RestrT m n a = RestrT {fromRestrT :: n (RestrTData m n a)}
> instance Monad n => Monad (RestrT m n) where
>     return = RestrT . return . RestrRet
>     RestrT nrmnx >>= f = RestrT $ nrmnx >>= handleRmnx
>         where handleRmnx (RestrRet x) = fromRestrT $ f x
>               handleRmnx (RestrBind mu g) = return $ RestrBind mu $ \x -> g x >>= f
> instance MonadTrans (RestrT m) where lift nx = RestrT $ liftM RestrRet nx
> embed mx = RestrT $ return $ RestrBind mx return
> unembed f = unembed'
>     where unembed' (RestrT nrmnx) = f $ liftM handleRmnx nrmnx
>           handleRmnx (RestrRet x) = restrReturn x
>           handleRmnx (RestrBind mu g) = restrBind mu $ unembed' . g
> instance MonadPlus n => MonadPlus (RestrT m n) where
>     mzero = RestrT mzero
>     RestrT nrmnx1 `mplus` RestrT nrmnx2 = RestrT $ nrmnx1 `mplus` nrmnx2
> type RestrM m a = RestrT m Identity a
> unembedId :: (RestrMonad m, Suitable m a) => RestrM m a -> m a
> unembedId = unembed runIdentity
> unembedPlus :: (RestrPlus m, Suitable m a) => RestrT m [] a -> m a
> unembedPlus = unembed restrMSum
Пример тоже выглядит в точности как раньше:

> test = unembedPlus $ do x <- embed $ Set.fromList [6, 2, 3]
>                         (do y <- return x
>                             z <- embed $ Set.fromList [1..2]
>                             guard $ y < 5
>                             return $ y + z)
>                         `mplus` return 10
Вот и всё.
 

Originally posted on migmit.vox.com