無限リストはComonadだってじっちゃが言ってたもんだから・・・

gistfile1.hs

{-# LANGUAGE DeriveFunctor #-}
module Main where
import Control.Applicative
import Test.QuickCheck
import Data.Maybe (fromJust)

class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)
  extend :: (w a -> b) -> w a -> w b

  extend f = fmap f . duplicate
  duplicate = extend id

(=>>) :: Comonad w => w a -> (w a -> b) -> w b
(=>>) = flip extend

-----

data Seq a = Seq a (Seq a) deriving (Show, Functor)

list2Seq :: [a] -> Maybe (Seq a)
list2Seq [] = Nothing
list2Seq xs = Just $ f xs xs
  where
    f :: [a] -> [a] -> Seq a
    f xs [] = f xs xs
    f xs (y:ys) = Seq y $ f xs ys

seq2List :: Seq a -> [a]
seq2List (Seq x xs) = x : seq2List xs

-----

instance Comonad Seq where
  extract (Seq x _) = x -- head
  duplicate xss@(Seq _ xs) = Seq xss $ duplicate xs -- tails :: [a] -> [[a]]

-- comonad laws
-- extract . duplicate = id
-- fmap extract . duplicate = id
-- duplicate . duplicate = fmap duplicate . duplicate

main :: IO ()
main = mapM_ quickCheck comonadLaws

comonadLaws :: [[Integer] -> Bool]
comonadLaws = 
  [ \xs -> appSeqFun (extract . duplicate) xs == appSeqFun id xs
  , \xs -> appSeqFun (fmap extract . duplicate) xs == appSeqFun id xs
  , \xs -> appSeqFun2 (duplicate . duplicate) xs == appSeqFun2 (fmap duplicate . duplicate) xs
  ]

-----

appSeqFun  :: (Seq a -> Seq b) -> [a] -> [b]
appSeqFun _ [] = []
appSeqFun f xs = take 500 . seq2List . f . fromJust . list2Seq $ xs

appSeqFun2  :: (Seq a -> Seq (Seq (Seq b))) -> [a] -> [[[b]]]
appSeqFun2 _ [] = []
appSeqFun2 f xs = (map . map) g . map g . appSeqFun f $ xs
  where g = take 40 . seq2List -- 計算量は爆発だ！