类型变量条件下的Haskell实例

Question

从我的问题的具体实例开始,我们都知道(并且喜欢)Monad类型类:

class ... => Monad m where
  return :: a -> m a
  (>>=)  :: m a -> (a -> m b) -> mb
  ...

考虑以下可能的实例,我们修改标准列表/"非确定性"实例nub,只保留每个"结果"的一个副本:

type DistinctList a = DL { dL :: [a] }
instance Monad DistinctList where
  return = DL . return
  x >>= f = DL . nub $ (dL x) >>= (dL . f)

你发现错误了吗？问题是,nub :: Eq a => [a] -> [a]所以x >>= f只在条件下定义f :: Eq b => a -> DistinctList b,而编译器要求f :: a -> DistinctList b.有什么方法我可以继续吗？

退一步,假设我有一个只是在参数类型变量的某些条件下定义的实例.我知道通常不允许这样做,因为使用类型类编写的其他代码无法保证提供符合条件的参数值.但是有没有这样的情况仍然可以实施？如果是这样,怎么样？

Answer 1

以下是对set-monad应用的技术的改编.

请注意,必须有一些"作弊".该结构包括额外的值构造函数来表示"返回"和"绑定".这些充当需要运行的暂停计算.该Eq实例是那里的部分run功能,同时创造了"中止"的构造是Eq免费的.

{-# LANGUAGE GADTs #-}

import qualified Data.List            as L
import qualified Data.Functor         as F
import qualified Control.Applicative  as A
import Control.Monad

-- for reference, the bind operation to be implemented
-- bind operation requires Eq
dlbind :: Eq b => [a] -> (a -> [b]) -> [b] 
dlbind xs f = L.nub $ xs >>= f

-- data structure comes with incorporated return and bind 
-- `Prim xs` wraps a list into a DL   
data DL a where
  Prim   :: [a] -> DL a
  Return :: a -> DL a
  Bind   :: DL a -> (a -> DL b) -> DL b

-- converts a DL to a list 
run :: Eq a => DL a -> [a]
run (Prim xs)             = xs
run (Return x)            = [x]
run (Bind (Prim xs) f)    = L.nub $ concatMap (run . f) xs
run (Bind (Return x) f)   = run (f x)
run (Bind (Bind ma f) g)  = run (Bind ma (\a -> Bind (f a) g))

-- lifting of Eq and Show instance
-- Note: you probably should provide a different instance
--       one where eq doesn't depend on the position of the elements
--       otherwise you break functor laws (and everything else)
instance (Eq a) => Eq (DL a) where
  dxs == dys = run dxs == run dys

-- this "cheats", i.e. it will convert to lists in order to show. 
-- executing returns and binds in the process        
instance (Show a, Eq a) => Show (DL a) where
  show = show . run

-- uses the monad instance
instance F.Functor DL where
  fmap  = liftM 

-- uses the monad instance
instance A.Applicative DL where
  pure  = return
  (<*>) = ap

-- builds the DL using Return and Bind constructors
instance Monad DL where
  return = Return
  (>>=)  = Bind

-- examples with bind for a "normal list" and a "distinct list"
list  =  [1,2,3,4] >>= (\x ->  [x `mod` 2, x `mod` 3])   
dlist = (Prim [1,2,3,4]) >>= (\x -> Prim [x `mod` 2, x `mod` 3]) 

这是一个肮脏的黑客,使其更有效,解决下面提出的关于绑定评估的要点.

{-# LANGUAGE GADTs #-}

import qualified Data.List            as L
import qualified Data.Set             as S
import qualified Data.Functor         as F
import qualified Control.Applicative  as A
import Control.Monad


dlbind xs f = L.nub $ xs >>= f

data DL a where
  Prim   :: Eq a => [a] -> DL a
  Return :: a -> DL a
  Bind   :: DL b -> (b -> DL a) -> DL a
--  Fail   :: DL a  -- could be add to clear failure chains

run :: Eq a => DL a -> [a]
run (Prim xs)      = xs
run (Return x)     = [x]
run b@(Bind _ _)   =
  case foldChain b of 
    (Bind (Prim xs) f)   -> L.nub $ concatMap (run . f) xs
    (Bind (Return a) f)  -> run (f a)
    (Bind (Bind ma f) g) -> run (Bind ma (\a -> Bind (f a) g))

-- fold a chain ((( ... >>= f) >>= g) >>= h
foldChain :: DL u -> DL u  
foldChain (Bind b2 g) = stepChain $ Bind (foldChain b2) g 
foldChain dxs         = dxs

-- simplify (Prim _ >>= f) >>= g 
--   if  (f x = Prim _)
--   then reduce to (Prim _ >>= g)
--   else preserve  (Prim _ >>= f) >>= g 
stepChain :: DL u -> DL u
stepChain b@(Bind (Bind (Prim xs) f) g) =
  let dys = map f xs
      pms = [Prim ys   | Prim   ys <- dys]
      ret = [Return ys | Return ys <- dys]
      bnd = [Bind ys f | Bind ys f <- dys]
  in case (pms, ret, bnd) of
       -- ([],[],[]) -> Fail -- could clear failure
       (dxs@(Prim ys:_),[],[]) -> let Prim xs = joinPrims dxs (Prim $ mkEmpty ys)
                                  in Bind (Prim $ L.nub xs) g       
       _  -> b
stepChain dxs = dxs

-- empty list with type via proxy  
mkEmpty :: proxy a -> [a]
mkEmpty proxy = []

-- concatenate Prims in on Prim
joinPrims [] dys = dys 
joinPrims (Prim zs : dzs) dys = let Prim xs = joinPrims dzs dys in Prim (zs ++ xs)  

instance (Ord a) => Eq (DL a) where
  dxs == dys = run dxs == run dys

instance (Ord a) => Ord (DL a) where
  compare dxs dys = compare (run dxs) (run dys)

instance (Show a, Eq a) => Show (DL a) where
  show = show . run    

instance F.Functor DL where
  fmap  = liftM 

instance A.Applicative DL where
  pure  = return
  (<*>) = ap

instance Monad DL where
  return = Return
  (>>=)  = Bind


-- cheating here, Prim is needed for efficiency 
return' x = Prim [x]

s =  [1,2,3,4] >>= (\x ->  [x `mod` 2, x `mod` 3])   
t = (Prim [1,2,3,4]) >>= (\x -> Prim [x `mod` 2, x `mod` 3]) 
r' = ((Prim [1..1000]) >>= (\x -> return' 1)) >>= (\x -> Prim [1..1000])