YonedaとCoYoneda、そしてFunctor

本当は、

Freeモナドを超えた！？operationalモナドを使ってみよう
http://fumieval.hatenablog.com/entry/2013/05/09/223604

に影響されて、Operationalモナドの話をまとめようと思ったのですが、ちょっと時間なさそうだったので、今日はちょっとCoYonedaの話をしましょう。
上記ブログでは、CoYonedaについて「ただのデータ型からFunctorを生み出せる」と紹介されています、これがいったいどういう事か、ちょっと深く追ってみましょう。

初めに

今回は、任意の型をFunctorにする事が目標なので、まず簡単に以下のような型を定義しておきます。

data Hoge a = Foo a | Bar a deriving Show

米田先生とYoneda

Yonedaというのは米田信夫という日本の数学者の名に因んだ「米田の補題」と関係のある型・・・なんだと思います。
「思います。」というのは、単にブログ主が米田の補題を理解してない*1だけの話なのですが・・・

さて、ekmett氏によるcategory-extrasというモジュールの、Control.Functor.Yonedaモジュールに、Yonedaというデータ型が以下のように定義されています。

{-# LANGUAGE ExistentialQuantification, RankNTypes #-}

data Yoneda f x = Yoneda { runYoneda :: forall b. (x -> b) -> f b }

YonedaはFunctorです。では、Yonedaをmapするというのはどういう事でしょうか。
これは、runYonedaの型がどう移り変わるか考えると、「「始域の関数」の始域」を書きかえる事になるのがわかります。

m :: Yoneda f x
k :: x -> y

とした時

m        :: Yoneda f x
fmap k m :: Yoneda f y
                     ^

つまり

runYoneda          m :: (x -> b) -> f b 
runYoneda $ fmap k m :: (y -> b) -> f b
                         ^

そのため、Yoneda型のfmapは次のように定義されています。

instance Functor (Yoneda f) where
  fmap f m = Yoneda $ \k -> runYoneda m (k . f)

以下のようにすると、実際に「「始域の関数」の始域」がfmapする度に変わっていく様子がわかります。

runYoneda                                    $ Yoneda (\k -> Foo (k 5)) :: Num x =>           (x      -> b) -> Hoge b
runYoneda                        . fmap show $ Yoneda (\k -> Foo (k 5)) ::                    (String -> b) -> Hoge b
runYoneda            . fmap read . fmap show $ Yoneda (\k -> Foo (k 5)) :: Read x =>          (x      -> b) -> Hoge b
runYoneda . fmap (*2). fmap read . fmap show $ Yoneda (\k -> Foo (k 5)) :: (Num x, Read x) => (x      -> b) -> Hoge b

Yonedaの双対CoYoneda

さて、今度はYonedaの双対を考えてみます。
基本的には関数の矢印の向きを逆にすれば良いので、runYonedaに対応するrunCoYonedaは次のように考えれば良いですね。

runYoneda	runCoYoneda
(x -> b) -> f b	f b -> (b -> x)

これを元に、CoYoneda型と、そのFunctorを定義すると次のような感じになります。

data CoYoneda f x = CoYoneda { runCoYoneda :: forall b. f b -> (b -> x) }

instance Functor (CoYoneda f) where
  fmap f (CoYoneda g) = CoYoneda $ \x d -> f $ g x d

CoYonedaのfmapは、「「終域の関数」の終域」を書きかえる事になります。

m :: CoYoneda f x
k :: x -> y

とした時

m        :: CoYoneda f x
fmap k m :: CoYoneda f y
                       ^

つまり

runCoYoneda          m :: f b -> (b -> x)
runCoYoneda $ fmap k m :: f b -> (b -> y)
                                       ^

えー、実際に書いてみるとよく解ると思うんですが、このCoYonedaの定義はｽｯｹﾞｰ使いづらいです。
このまんまだとちょっと使い物にはならなさそうなので、形を変えてみましょう。

f b -> (b -> x)という型は、次のように考える事ができます。

(->) (f b) (b -> x)

この、(->)をデータコンストラクタCoYonedaに置き換えてみましょう。

CoYoneda (f b) (b -> x)

つまり、CoYonedaとは、f bという値と、(b -> x)という関数のペアと考える事ができます。*2 *3
ここで、fmapによって(b -> x)の終域を書きかえるのは簡単です。(x -> y)という関数と関数合成すれば(b -> y)という型を得ることができます。

従って、CoYonedaの型と、Functorの定義は次のようになります。

data CoYoneda f x = forall b. CoYoneda (f b) (b -> x)

instance Functor (CoYoneda f) where
  fmap f (CoYoneda v g) = CoYoneda v (f . g)

こうすれば、任意の型をCoYoneda型に持ち上げるliftCoYonedaの定義は簡単です。

liftCoYoneda :: f a -> CoYoneda f a
liftCoYoneda x = CoYoneda x id

元の定義から(f b)と(b -> x)を入れ替えると、liftCoYonedaの定義はもっと簡単になります。

{-# LANGUAGE ExistentialQuantification #-}

data CoYoneda f x = forall b. CoYoneda (b -> x) (f b)

instance Functor (CoYoneda f) where
  fmap f (CoYoneda g v) = CoYoneda (f . g) v

liftCoYoneda :: f a -> CoYoneda f a
liftCoYoneda = CoYoneda id

というかこれなら、liftCoYonedaの定義は不要なくらいですね・・・実際にこのCoYonedaはcategory-extrasに定義されているものと同じです。
この改訂版CoYoneda型はなかなか優秀です。まず値を作るのが簡単なのが良いですね。

CoYoneda id (Foo 5)      :: Num x => CoYoneda Hoge x
CoYoneda id (Bar "Hoge") :: CoYoneda Hoge [Char]

CoYonedaはFunctorなので、当然fmapできます。

let foo5 =  CoYoneda id (Foo 5) :: CoYoneda Hoge Integer

として

fmap show foo5 :: CoYoneda Hoge String

さて、ここからが問題です。
CoYoneda Hoge aから、Hoge aだけ取り出すにはどうすれば良いでしょうか？

えー・・・

結局ですね、パターンマッチしてデータコンストラクタの数だけCoYonedaを剥がす計算を書いてやる必要があるんですね・・・

runFoo :: CoYoneda Hoge a -> Hoge a
runFoo (CoYoneda f (Foo a)) = Foo (f a)
runFoo (CoYoneda f (Bar a)) = Bar (f a)

なんやー(´・ω・`)これなら普通にHogeをFunctorにしたほうがえーやんなー・・・

と、思いません？
僕は思います。

もし、Freeモナドを知らなければね

Free+CoYoneda→Operational

Freeモナドについて詳しい事は、ブログ主の過去の記事とか、@fumievalさんの記事でも参照してください。
任意のFunctorをモナドにする事ができ、それによって簡単に言語内DSLが作れるすぐれものでしたね。

何も無い所からFunctorを作るのがCoYoneda、Functorからモナドを作るのがFreeモナド、では、この二つを組み合わせたらどーなるのっと。

type Program f a = Free (CoYoneda f) a
data MyPg a = Order1 a | Order2 a

type MyProgram a = Program MyPg a

singleton :: f a -> Program f a
singleton = liftF . liftCoYoneda

order1 = singleton $ Order1 () :: MyProgram ()
order2 = singleton $ Order2 () :: MyProgram ()

runMyPg :: MyProgram a -> IO a
runMyPg (Free (CoYoneda f o)) = runOrder o >>= runMyPg . f
  where
    runOrder :: MyPg a -> IO a
    runOrder (Order1 n) = putStrLn "Order1 Called!!" >> return n
    runOrder (Order2 n) = putStrLn "Order2 Called!!" >> return n
runMyPg (Pure a) = return a

----
-- Test --

program :: MyProgram ()
program = do
  order1
  order2
  order2
  order1

main :: IO ()
main = runMyPg program

実行結果：

Order1 Called!!
Order2 Called!!
Order2 Called!!
Order1 Called!!

こうなります。
MyPgをFunctorにする事無く、Freeで言語内DSLに仕立て上げてしまいました。

「Freeよりも簡単にモナドが作れる！」が売り文句のOperationalはこんな仕組みらしいです。
ブログ主もいずれ、詳しい事書きますが、「勿体ぶってんじゃねぇよ！！」という方は、冒頭で紹介した@fumievalさんの記事をもう一度記載しますので、参照してください。

Freeモナドを超えた！？operationalモナドを使ってみよう：
http://fumieval.hatenablog.com/entry/2013/05/09/223604

おまけ

「ところでブログ主、category-extrasをインストールしていないらしいけど」
「・・・（黙秘）」
「またcabalの依存関係が解決できなかったんですか？」
「・・・（泣き顔）」
「ザコですね」
「・・・ｳｯ・・・ｳｯｳｯ・・・（号泣）」

*1:圏論ｺﾜｲ

*2:圏論的にはf bと(b -> x)間の射が(->)かCoYonedaなのかの違いで、基本的には同型なんじゃないかなーと思います。と思ったけど、この間の関手を上手く定義できないので違いますねー

*3:Twitterで軽く話題に出してみたら同型というより随伴という関係っぽい・・・？圏論わからん！

こもなど！コモナド！Comonad！！

どうも。
清く正しいHaskell戦士ちゅーんさんです。

今日はアレです。

Comonad

やってきます。

えー・・・

「こ」

「コ」

「Co」

Coってなんすか。カレーハウスっすか。丸い響きの音を付けて可愛く見せれば良いと思ってるんですか。
いやいや、騙されませんよ、後ろのmonadから察するにどう考えても圏論用語です。本当に（ry

という感じで、名前からして怪しげな臭いをプンプンと漂わせているComonadを見てみたいと思います。
とりあえず、お約束なので、Hackageに行ってComonadクラスの定義を見てきましょう。

http://hackage.haskell.org/packages/archive/comonad/0.1.1/doc/html/Control-Comonad.html

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

例によって抽象的で、なんやねんコレ感半端ないですが、よく見るとどれも何処かでみたような型と似ています。

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

join :: Monad m => m (m a) -> m a
join x = x >>= id

MonadとComonadの関数は以下のように対になっているのです。

Comonad	Monad
extract:: w a -> a	return :: a -> m a
duplicate :: w a -> w (w a)	join :: m (m a) -> m a
(=>>) :: w a -> (w a -> b) -> w b	(>>=) :: m a -> (a -> m b) -> m b

あ、はい。
だから名前に「monad」が付いてるんですね。

任意のデータ構造をComonadにするためには、extendかduplicateのどちらかを実装すれば良いのですが、これはMonadの(>>=)とjoinがそれぞれお互いを使って次のように定義する事ができるのと対応してます。*1

*Main> :t \f x -> join (fmap f x)
\f x -> join (fmap f x)
  :: (Monad m, Functor m) => (a1 -> m a) -> m a1 -> m a
*Main> :t (>>=id)
(>>=id) :: Monad m => m (m b) -> m b

---

二値のタプルはFunctorです。

class Functor f where
  fmap :: (a -> b) -> f a -> f b
  (<$) :: a -> f b -> f a
  	-- Defined in `GHC.Base'

...

instance Functor ((,) a) -- Defined in `GHC.Base'

そして、二値のタプルはComonadでもあります。

class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)
  extend :: (w a -> b) -> w a -> w b
  	-- Defined in `Control.Comonad'

...

instance Comonad ((,) e) -- Defined in `Control.Comonad'

さて、Monadのjoinは、m (m a) から m aの の自然な変換です。それに対してComonadのduplicateは w a から w (w a) への「自然」な変換になります。
二値のタプルの場合は、一番目の要素を繰り返す事で、(a, b)から(a, (a, b)) へと自然に変換を行うワケです。

*Main> duplicate (1, 10)
(1,(1,10))
*Main> duplicate ("hoge", 10)
("hoge",("hoge",10))

extendは特殊な関手ですね。第一引数で要求している型はextract関数と組み合わせで作ることができます。

*Main> :t (*2) . extract
(*2) . extract :: (Num c, Comonad w) => w c -> c
*Main> :t show . extract
show . extract :: (Show b, Comonad w) => w b -> String

これでfmap同様、第一引数をそのまま、第二引数の値に関数を適用する事ができます。

*Main> extend ((*2).extract) (1, 15)
(1,30)
*Main> extend (show.extract) (1, 100)
(1,"100")

このextendを使ったfmapの実装は、liftWとしてComonadモジュールに定義されています。

liftW :: Comonad w => (a -> b) -> w a -> w b
liftW f = extend (f . extract)

先ほどの型定義でも見たとおり、extend flipした演算子…Comonadの(=>>)はMonadの(>>=)と対になっているのでした。
いつも>>=でやっているようにして、計算を合成していってみましょう。

*Main> ("hoge", 1) =>> (+2) . extract =>> (*2) . extract =>> show . extract
("hoge","6")
*Main> ("hoge", 1) =>> (+2) . extract =>> fst
("hoge","hoge")

で、これちょっとStateっぽいなーと思ったんですが*2、(=>>)の型の性質上、ぶら下がりラムダを使って途中計算で変数を束縛とかできないので上手いこといかず。
大抵の場合はfmapと関数結合（ないしArrow）で事足りそうなイメージ。

これだけ見ると、Monadの(>>=)ほど面白い事はできなさそうですね・・・
結局色々考えてみたのですが、Comonadで一番重要なのは、その本質である「値が取り出せるFunctor」を多相に扱う事ができるという点にあるように見えます。*3
タプルのextractはsndと等価ですね。

*Main> snd (1, 10)
10
*Main> extract (1, 10)
10

---

もう流石に慣れてきましたが、こういう圏論由来の型に対して即実用性を見つけようとするのはナンセンスなので、使用例とか色々見ながら、感覚掴んでいくのが良さそうです。
そういえば、以前fumievalさんが「Comonadでオブジェクト指向を実現できる」と言っていたような気がしますが、残念ながらソースが見つけられず。

「ところで「Co」って何ですか？」
については、Twitterで @myuon_myon さんに回答頂いたので、内容そのまま紹介させて頂きます。

ブログにコメントするの怖いのでこちらで。Coは「双対」を表す概念で、簡単に言えばある概念Aを可換図式で表した時に、それの射の向きを全てひっくり返したものが「Aの双対」と呼ばれます。ComonadはMonadの双対なのでこの名前がついています。

とゆーことだそうです、ありがとうございましたm(__)m

*1:型クラスに制約はありませんが全てのMonadはFunctorになります

*2:fstがgetとして使えるので

*3:内包された値を自然な形で取り出す事ができるあらゆるFunctorはComonadになると考えて良いのでしょうか？ListやMaybeがComonadにならないのは明らかですね。

Profunctorを咀嚼する

先週のekmett勉強会でliyanghuさんが紹介して下さったprofunctorがちょっと興味深いので、まだ完全に飲み込めては居ないのですが、簡単に纏めてしまおうと思います。

さて、我々にとってFunctorと言えば「fmap :: (a -> b) -> f a -> f b」というメソッドを持った型クラスFunctorの事ですが、圏論で言う所の関手(Functor)を表現した型は、Functor型クラスの他にも色々あるんだそーです。

例えば、Data.Functor.ContravariantというモジュールのContravariantとか、Data.BifunctorのBifunctorとかもそうですし、今回ご紹介するData.ProfunctorモジュールのProfunctorは、ContravariantとBifunctor双方の特徴を併せ持ったようなFunctorの一つです。

ちゃちゃっと型定義を見てみましょう。

class Profunctor f where
  dimap :: (c -> a) -> (b -> d) -> f a b -> f c d

dimapの特徴は、先述のliyanghuさんの文章にある記述がとても解りやすいのでそのまま引用させて頂きます。

      g   ::   a   <-   c
        h ::     b ->     d
dimap g h :: f a b -> f c d

関数gの型定義の矢印が逆向きになっているので、型の作りが一目で解る素晴らしい表記ですね。

---

で、この矢印が逆向きになる感覚、Contravariant型クラスの実装例を見るとイメージしやすいので、ちょっと見てみましょう。

class Contravariant f where
    contramap :: (b -> a) -> f a -> f b

正直ブログ主、最初この定義を見た時、(ﾟДﾟ)ﾊｧ?ってなりました。
ネタばらしするとシンプルなんですけどね。

newtype Predicate a = Predicate { getPredicate :: a → Bool }

instance Contravariant Predicate where
  contramap g (Predicate p) = Predicate (p . g)

newtype Op b a = Op (a → b)

instance Contravariant (Op b) where
  contramap g (Op f) = Op (f . g)

このように、型 f a が 「aを取る関数」を持っているような場合、contramapの型を満足させる事ができるというワケです。
fが型aの値そのものを持っていなくてはいけないとゆー、しょーもない固定概念が邪魔をして違和感を感じてしまうのですね。

---

さて、「逆向きの矢印」をどう満足させるかは解ったので、とりあえずprofunctorのdimap関数の型を満足させるFooを適当に考えて見る事にしましょう。

newtype Foo c a b = Foo (a -> c, b)

instance Profunctor (Foo c) where
  dimap f h (Foo (x, y)) = Foo (x . f, h y)

これでいちおうFoo型をProfunctorの型はなんとなく解りましたが、ぶっちゃけ何が嬉しいのか良く解りません。

もうちょい実用的な例は無いんですかー。
と思ったあなたに朗報、実はむっちゃんこ身近に、Profunctorになる型があったりします。

instance Profunctor (->) where
  dimap ab cd bc = cd . bc . ab

そです。関数はめっちゃくちゃ綺麗にProfunctorになるのです。
その働きは型を見れば一発です。

dimap :: (c -> a) -> (b -> d) -> (->) a b -> (->) c d

つまり

dimap :: (c -> a) -> (b -> d) -> (a -> b) -> (c -> d)  

profunctorのインスタンスとしてdimapに渡された関数 (a -> b) は、２つの関数(c -> a)と(b -> d) を繋ぐノリのような役割を果たします。

さらにprofunctorには、以下の型を持つlmapとrmapという関数を持っています。

-- 一つ目の型変数のみmap
lmap :: (a -> b) -> f b c -> f a c
                      ^        ^

-- 二つ目の型変数のみmap
rmap :: (b -> c) -> f a b -> f a c
                        ^        ^

これは、dimapさえ定義されていれば、以下のようにして実装できます。

lmap f = dimap f id
rmap = dimap id

(->)のlmapとrmapの型は、次のように始域と終域を書きかえるという性質を持ちます。

lmap :: (a -> b) -> (b -> c) -> (a -> c)
                     ^           ^

rmap :: (b -> c) -> (a -> b) -> (a -> c)
                          ^           ^

これは、Arrowの持っている性質と同じですね*1。

Prelude Control.Arrow> :t (^>>)
(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
Prelude Control.Arrow> :t (<<^)
(<<^) :: Arrow a => a c d -> (b -> c) -> a b d

うーん、なんとなくProfunctorのパワーが見えてきたような気がします。

---

はてさて、FunctorやMonadもそうですが、こういう抽象的な型について考える場合、現実的な具体例をいくつか上げていって、「それらが全て多相に扱う事ができる」というような捉え方をする必要があるので、「理解＝納得」に繋がりにくいのですよね(´・ω・`)

とゆーワケで、実際にHackageを覗いてみて、どんなものがProfunctorになるのか見てみると・・・うげげ、見たことの無い型がいっぱいでござる。

Profunctor (->)	 
Monad m => Profunctor (Kleisli m)	 
Functor w => Profunctor (Cokleisli w)	 
Profunctor (Tagged *)	 
Profunctor (Forget r)	 
Arrow p => Profunctor (WrappedArrow p)	 
Functor f => Profunctor (DownStar f)	 
Functor f => Profunctor (UpStar f)	 

Kleisliっていうのはクレイスリ圏のアレですよね。案の定モナドと仲が良さそうです。CokleisliはComonad関係ですか？なんかどちらも怪しげな香りがしてきます。
Taggedっていうのは・・・ちゃんと見ないと解らなさそうですね、時間が無いのでまた今度。ForgetはConstantにちょっぴり似てます。

WrappedArrowはどうやら、ArrowをProfunctorにラップするための型のようです。
あと、DownStarとUpStarはそれぞれFunctorをProfunctorにラップするための型ですね。
これらはなんか面白そうな雰囲気を醸し出してるのでちゃんと見てみたいかも。

あとは、前回の記事で紹介した、liyanghuさんの発表資料には、さっきのFoo型よりよっぽどマトモな例として、Limitsという型を作ってProfunctorにする例や、IndexedもProfunctorだよ！みたいな例が掲載されているので、ここで再掲させて頂きます。
https://www.fpcomplete.com/user/liyang/profunctors

「PROFUNCTORS EVERYWHERE」という事なので、もっと直感的にdimapを捉えられれば、、かなり視野が開けるかもしれません。

というわけで今回はこれにて、ノシノシ

*1:ekmett勉強会の時のkhibinoさんの受け売りですが

Ekmett勉強会at渋谷 #ekmett_conf

数多くのHaskellライブラリのを手がけるEdward Kmettさんのライブラリを勉強しよう！
という趣向で開催されたekmett勉強会に参加して来ました。

本当はその日の内容を一つ一つご紹介できれば良いのですが、うっかりメモのファイルを削除するというドジっ子っぷりをキめてしまったので、曖昧な記憶を元に「こんなんだったお＞＜。」という話を書こうかなと思います。

• lens

ブログ主担当。発表資料は以下。
http://www.slideshare.net/itsoutoftunethismymusic/ekmett-17955009

https://github.com/ekmett/lens/wiki/Derivation を大いに参考にしました。

発表後パフォーマンスについての質問があったのですがお勉強不足でお答えできず。
ekmett氏曰く、「黒魔術使ってるから、いまやbaseライブラリより速い場合すらあるYO☆」との事。

まぢですか・・・

• Free

Lazy KのとfreeGameでおなじみ、fumievalさん担当。
FunctorからMonadを構築するFreeモナドを初め、freeモジュール内の色んなライブラリを紹介して下さいました。

ちなみにFreeモナドについては、このブログでも紹介した事あります。
http://d.hatena.ne.jp/its_out_of_tune/20121111/1352632815

チャーチエンコーディングを使ったFreeモナドの作り方、ちゃんと理解したいなぁ。

• machines

halcat0x15aさん担当。
なんか面白そうだなぁとは思ったんですか、どういう時にどうやって使うのかイマイチ理解できませんでした(´・ω・`)
http://halcat0x15a.github.com/slide/machines/out/ に資料ありますので、今度ゆっくり読んでみます。

• ad

Nebutaさん担当。自動微分ライブラリだそうです。
すんません、数学赤点常習犯だったので微分がちゃんと解ってませんorz

資料はこちら
http://www.slideshare.net/nebuta/haskell-ad34

• tables

yugaさん担当。
Lensを使ったインメモリDB。CSV読み込んでゴニョゴニョするのに小回りが効いて便利そう。

資料はこちら
http://jutememo.blogspot.jp/2011/05/haskell-cps.html

• speculation

ma0eさんによる投機実行ライブラリspeculationの紹介。
((((；ﾟДﾟ))))unsafeいっぱいコワイ

資料はこちら。
https://speakerdeck.com/maoe/speculation

• profunctor

liyanghuさんによる、profunctorライブラリの紹介。
英語力低すぎて全然聞き取れなかったので、現在資料をゆっくり読み進めてるところです・・・が・・・。

ちょっとこれ面白いかもしれない。
https://www.fpcomplete.com/user/liyang/profunctors

khibinoさんによる日本語の補足資料
http://www.slideshare.net/khibino/profunctor-and-arrow-17939130

後日、記事書くかも。

• trifecta

tanakhさんによる、超モダンなパーサーコンビネータの紹介。
ライブコーディングではたった8分でJSONのパーサを書き上げてしまいました。

資料はこちら。
https://gist.github.com/tanakh/d7a089341a011118a1cd

• reflection

mkothaさんによる発表。

「型を引数として使うライブラリ」だそうです(´・ω・`)？
完全にHaskell力が足りない・・・

資料：http://www.kotha.net/misc/ekmett_conf/reflection.html

• bound

De Bruijn termsのライブラリ。これTaPLに書いてあったやつや！！！
http://hexx.github.io/bound-slides/#1

まだあんまりDe Bruijn termsを良くわかってないので、もうちょいTaPLを読み進めたら、この資料もっぺん一読したいですねー。

---

これで全部・・・かな？
その後、オンラインで参加されてるekmett氏へのQAが行われていたのですが、英語がほとんど聞き取れず。

kmettさんの驚異的な抽象力の源泉は「圏論」なんだそうな。
tk_shgさんが彼の紹介してくれた書籍を http://taketoncheir.hatenablog.com/entry/2013/04/01/131020 に纏めて下さいました。

んー、プログラミング全般について色々考えることはあるのですが、やっぱりHaskellが好きだなぁーという事を改めて実感した一日です。
いつの日かHaskell漬けの生活がしたいなーと思ったので、日々お勉強頑張りますYO(｀・ω・´)

LensちゃんマジLens

なんとゆーか、もともと手元にあるものを使ってちくちく何かをするのが好きなので、有名なライブラリとか大きいパッケージとか見ても尻込みしてしまってなかなか手を付けられないタイプなのですが、ここへ来て色々後回しにしてたツケが回ってきた感あります。

はい、そんな感じでここ数日、ようやくcabalの洗礼を受ける事ができました、ちゅーんさんです。
んで、仕事の間を縫ってゲーム作ったりなんかも、カタツムリの歩みで進めていたりもするのですが、急遽Lensを理解する必要がでてきたので今日はLensの導入やります。

あ、あとYesodを覚えようと思ったのですが、どうもこのライブラリ、一通り使えるようになるまでが修羅の道らしく、髪の毛を掻きむしりながらcabalと格闘してやっとインストールができたと思ったら今度はyesod develで詰んだり*1してます。
そんなこんなで、今日はLensの導入やりますってば。

てば。

---

早速Lensちゃんをインストールしてきました。
そもそもcabalのバージョン低いままずっと使ってたので、upgradeするのにも一苦労だったのですが、一旦それが済めば...

cabal install lens

で一発ですね。らくちんらくちん。

わりとでっかいライブラリだからコンパイルに時間かかりますので、コーヒーでも飲みながら待ちましょう。
ちなみにブログ主はほうじ茶飲みながらスーパーマリオ３Dワールドやってました。思いの外ガチゲーですね、これ。

で、先述のように、でっかいライブラリなので、一回のエントリで本質に迫ったり細部まで網羅したりとかどー考えても無理なので、基本的な機能を使って色々遊んでみるのに留めましょう。

---

とりあえず、Lensを導入する事によって一番嬉しいのは、任意のデータ構造に対して「可読性が高く」「片安全」なアクセサを得る事ができる点かと思われます。

まず、チュートリアルでいきなり出てくる次のサンプルコードから。

Prelude Control.Lens> ("Hoge", "Piyo", "Huga", "Hogera")^._1
"Hoge"
Prelude Control.Lens> ("Hoge", "Piyo", "Huga", "Hogera")^._2
"Piyo"
Prelude Control.Lens> ("Hoge", "Piyo", "Huga", "Hogera")^._3
"Huga"
Prelude Control.Lens> ("Hoge", "Piyo", "Huga", "Hogera")^._4

こんな感じで、タプルに添字でアクセスできるように（見えるように）なります。
このサンプル、アレです。確かに「ふぉぉ、すげぇ！」ってなるんですけど、パッと見何処で区切って読んだら良いかわかりません。
もちろん、(^.)が演算子で、`_x`は関数名ですね。はい。

Prelude Control.Lens> :i (^.)
(^.) :: s -> Getting a s t a b -> a
  	-- Defined in `Control.Lens.Getter'
infixl 8 ^.
Prelude Control.Lens> :i _1
class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where
  _1 :: (Indexable Int p, Functor f) => p a (f b) -> s -> f t
  	-- Defined in `Control.Lens.Tuple'

とりあえず、型定義がカオスなので、中身の理解は一旦置いておきましょう。
例えば、「タプルの中のタプルの中のタプル中の要素にアクセスしたい！」って時とか、関数合成(.)と組み合わせて次のように書くとすごく読み易いです。

Prelude Control.Lens> (1, ('a', 'b', ("Hoge", "Piyo")), 2)^._2._3._1
"Hoge"

この仕組は、関数合成した結果の型を見れば一目瞭然...

Prelude Control.Lens> :t _2._3._1
_2._3._1
  :: (Functor f, Field3 s1 t1 s2 t2, Field2 s t s1 t1,
      Field1 s2 t2 a b, Indexable Int p) =>
     p a (f b) -> s -> f t

では無いですねｗ

まぁ、合成する前の型と同じ型になっているので、結果として同じ動きをしているのは納得できます。

Prelude Control.Lens> :t _1
_1
  :: (Functor f, Field1 s t a b, Indexable Int p) =>
     p a (f b) -> s -> f t
Prelude Control.Lens> :t _1._2
_1._2
  :: (Functor f, Field2 s1 t1 a b, Field1 s t s1 t1,
      Indexable Int p) =>
     p a (f b) -> s -> f t
Prelude Control.Lens> :t _1._2._3
_1._2._3
  :: (Functor f, Field3 s2 t2 a b, Field2 s1 t1 s2 t2,
      Field1 s t s1 t1, Indexable Int p) =>
     p a (f b) -> s -> f t

なになに？「タプルの中のタプルの中のタプル中の要素に関数を適用した結果が欲しい！」ですって？
よかろう、ならばto関数を使い給え。

Prelude Control.Lens> (1, ('a', 'b', ("Hoge", "Piyo")), 2)^._2._3._1.to length
4
Prelude Control.Lens> (1, ('a', 'b', ("Hoge", "Piyo")), 2)^._2._3._1.to (map Data.Char.toUpper)
"HOGE"

で、今度は「タプルの中のタプルの中のタプル中の要素を書き換えたい！」みたいな時に活躍するのが(.~)演算子であります。

Prelude Control.Lens> :t (.~)
(.~) :: ASetter s t a b -> b -> s -> t

この演算子は左辺のアクセッサ関数で指定された場所を右辺の値で書きかえる関数を返す高階関数になってますので、次のようにして任意のフィールドの値を書きかえる事ができます。

Prelude Control.Lens> _2._3._1 .~ 99999 $ (1, ('a', 'b', ("Hoge", "Piyo")), 2)
(1,('a','b',(99999,"Piyo")),2)

やりようではありますが、同じ事を従来の方法でやろうとするとけっこう大変です。

Prelude Control.Lens> (\(a1, (b1, b2, (_, c2)), a3) -> (a1, (b1, b2, (99999, c2) , a3))) (1, ('a', 'b', ("Hoge", "Piyo")), 2)
(1,('a','b',(99999,"Piyo"),2))

と、いっちゃんベタな方法で書きましたが、見通し悪い上、一時変数に塗れててとっても格好悪いです、これ。
さぁ、Lensのパワーがだんだん見えてきました。

---

といって、まるでLensちゃんがタプルを便利に使うための機能みたいな扱いになってしまうとあまりにも可哀想なので、再度(^.)と(.~)の型定義を見てみましょう。

Prelude Control.Lens> :t (^.)
(^.) :: s -> Getting a s t a b -> a
Prelude Control.Lens> :t (.~)
(.~) :: ASetter s t a b -> b -> s -> t

型引数が多くて細部の憶測は立てづらいですが、各々GettingとかASetterという型を引数に乗っているのが確認できます。

Prelude Control.Lens> :i Getting
type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t
  	-- Defined in `Control.Lens.Getter'
Prelude Control.Lens> :i ASetter
type ASetter s t a b = (a -> Mutator b) -> s -> Mutator t
  	-- Defined in `Control.Lens.Setter'

それぞれ、AccessorとMutatorという型を引数に取る関数の型の別名である事が解ります。

Prelude Control.Lens> :i Accessor
newtype Accessor r a = Accessor {runAccessor :: r}
  	-- Defined in `Control.Lens.Internal.Getter'
instance Functor (Accessor r)
  -- Defined in `Control.Lens.Internal.Getter'
instance Gettable (Accessor r)
  -- Defined in `Control.Lens.Internal.Getter'
Prelude Control.Lens> :i Mutator
newtype Mutator a
  = Control.Lens.Internal.Setter.Mutator {Control.Lens.Internal.Setter.runMutator :: a}
  	-- Defined in `Control.Lens.Internal.Setter'
instance Monad Mutator -- Defined in `Control.Lens.Internal.Setter'
instance Functor Mutator
  -- Defined in `Control.Lens.Internal.Setter'
instance Traversable Mutator
  -- Defined in `Control.Lens.Internal.Setter'
instance Settable Mutator
  -- Defined in `Control.Lens.Internal.Setter'
Prelude Control.Lens> 

Monad、Functorは説明不要として、ここでTraversable、Gettable、Settableという型クラスが出てきました。任意の型がこれらの型クラスのインスタンスとなっていれば、同じようにして簡単に任意のフィールドへアクセスできるようになるという事ですね。この型クラスを理解する事がLensの理解に繋がりそうです。

あ、あと、使うだけなら大した問題では無いのでここまで触れていなかったのですが、(^.)と(.~)はそれぞれ、view関数と、set関数のaliesになってます。

Prelude Control.Lens> view _2 ('a', 'b', 'c')
'b'
Prelude Control.Lens> set _2 "Hoge" $ ('a', 'b', 'c')
('a',"Hoge",'c')

---

んでっ！
「俺の作ったデータ型もLensで格好良くアクセスできるようにしてーけど、型定義とかややこしいし面倒くさいんじゃねーの？」というあなた！

ご安心下さい、任意の型を超楽チンにLensのインスタンスにする必殺技*2が予め用意されているのです！

というのが以下のサンプルコードで・・・

{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}

module Main where
import Control.Lens

data Hoge a = Hoge {
  _foo :: a,
  _bar :: Int
  } deriving (Show, Eq)

makeLenses ''Hoge

なんかゴチャゴチャとGHC拡張付けないとコンパイル通らないのが気持ち悪いですが、純粋なHaskellだとちょっと非力なので我慢我慢。
こんだけの定義でHoge型に対してviewやらsetやら使えるようになるんだから安いもんです。

"makeLenses ''型名" っていう記述がミソみたいですね。
どうやらこの一行を入れてやると、任意の型の各フィールドに対するアクセサ関数がコンパイル時に自動で生成されるっぽいです。
【15:21 修正】もともとmakeClassyを使っていましたが、こちらは型クラスも合わせて生成する構文らしく、反面一部の記述が制限されるので、makeLensesに差し替えました

実際にghciで使ってみたのが以下になります。

*Main> :t foo
foo :: Functor f => (a0 -> f a1) -> Hoge a0 -> f (Hoge a1)
*Main> :t bar
bar :: Functor f => (Int -> f Int) -> Hoge a0 -> f (Hoge a0)
*Main> (Hoge "Foo" 1)^.foo
"Foo"
*Main> (Hoge "Foo" 1)^.bar
1
*Main> ("Nyan" ,(Hoge "Foo" 1))^._2.foo
"Foo"
*Main> (Hoge (Hoge "Foo" 999) 10)^.foo.bar
999
*Main> _2.foo .~ "Bar" $ ("Nyan" ,(Hoge "Foo" 1))
("Nyan",Hoge {_foo = "Bar", _bar = 1})

やだ何コレ面白い

---

そんなワケで、可愛い可愛いLensちゃん*3のお話でした。

凄いは凄いんですけどどーしてこうなるのかちょっと外見だけだと検討付かないですねｗ
という疑問の良い解説になりそうな文章がWikiにありました。

https://github.com/ekmett/lens/wiki/Derivation(英)

近日中にコレを読んだら、スライド作りに励もうかと思います。でわでわノシノシ。

---

【15:35 追記】

(.~)を使ったSetterですが、flip ($)と外延的等価な演算子(&)がControl.Lens.Combinatorsで定義されていまして・・・

*Main> :t flip ($)
flip ($) :: b -> (b -> c) -> c
*Main> :t (&)
(&) :: a -> (a -> b) -> b

それを使うと、OOの代入文みたいな順序で記述できます。
こっちのほうが読みやすくて良いですね。

*Main> ((1, 2, 3), "Hoge", "Piyo")&_1._2 .~ True
((1,True,3),"Hoge","Piyo")

*1:cabal: Cannot find the program 'ghc' at 'yesod-ghc-wrapper' or on the path・・・ｹﾞﾌｩ・・・そんなぁ、ちゃんとPATH切ってあるのにー！！

*2:TemplateHaskellですね、ﾊｲ

*3:ちょっとおデブなのが気になりますが！

たなかさんのおにくをたべよう

Haskell界の有名なエンジニアで、「すごいH本」ことすごいHaskellたのしく学ぼうの翻訳もされている田中英行さんのご自宅にて、少人数のハッカソン「たなかにくまつり」が開催されたので参加して来ました。

開催されるまでの経緯とか色々あるのですが、とにかくまぁ、尊敬しているHaskellerさんと直接お話できる機会と思いエントリーしたわけですね。決して他意は無いです。

無いですってば。

意気揚々と参戦したものの、やっぱり皆さんレベルが高い高い。結局、話にまともに付いていけたのはモナドに関する話題くらいでして。
しゃーないので、はしっこのほうでタコ焼きをもちゃもちゃ食べながらコードを書いていた次第です。

せっかくFreeモナドの使い方を覚えたので、Parsecの勉強と合わせて簡単なスタック型プログラミング言語を作ってみようと思っていたのですが、流石に１日だけだと構文木とインタプリタ処理系を作るのが限界でした。
状態を保持するための領域がスタックだけの言語なので、チューリング完全では無いんじゃないかなぁと思います。

とりあえず、大したものでは無いから、なるべく早いうちに完成させてしまうつもりなので、構文とか言語仕様の話はその時に書くとしましょう。
とりあえず今日はコードだけ貼っておくので、テストコードから雰囲気だけ掴んで貰えれば良いかと思われます。
Freeモナドにすると、do構文でほぼそのままの記述ができるのは嬉しいです。

Language/BricksLang/SyntaxTree.hs:

module Language.BricksLang.SyntaxTree where
import Control.Monad.Free

---------------------------------------------------------------------------------------------------
--構文木データ定義

data Bricks a
  = BricksPush Int a
  | BricksPop a
  | BricksPutChar a
  | BricksPutInt a
  | BricksAdd a
  | BricksEq a
  | BricksLabel String a
  | BricksGoto String a
  | BricksThrow String a
  deriving (Show, Eq)

--Freeモナドで扱うためにFunctorにする
instance Functor Bricks where
  fmap f (BricksPush x n) = BricksPush x (f n) 
  fmap f (BricksPop n) = BricksPop (f n) 
  fmap f (BricksPutChar n) = BricksPutChar (f n) 
  fmap f (BricksPutInt n) = BricksPutInt (f n) 
  fmap f (BricksLabel l n) = BricksLabel l (f n)
  fmap f (BricksAdd n) = BricksAdd (f n) 
  fmap f (BricksEq n) = BricksEq (f n) 
  fmap f (BricksGoto l n) = BricksGoto l (f n) 
  fmap f (BricksThrow m n) = BricksThrow m (f n)

---------------------------------------------------------------------------------------------------
--構文を組み立てるFreeモナド関数化

liftF :: Functor f => f r -> Free f r
liftF cmd = Impure (fmap Pure cmd)

bPush :: Int -> Free Bricks ()
bPush x = liftF $ BricksPush x ()

bPop :: Free Bricks ()
bPop = liftF $ BricksPop ()

bPutChar :: Free Bricks ()
bPutChar = liftF $ BricksPutChar ()

bPutInt :: Free Bricks ()
bPutInt = liftF $ BricksPutInt ()

bLabel :: String -> Free Bricks ()
bLabel m = liftF $ BricksLabel m ()

bGoto :: String -> Free Bricks ()
bGoto m = liftF $ BricksGoto m ()

bAdd :: Free Bricks ()
bAdd = liftF $ BricksAdd ()

bEq :: Free Bricks ()
bEq = liftF $ BricksEq ()

bThrow :: String -> Free Bricks ()
bThrow m = liftF $ BricksThrow m ()

Language/BricksLang/Interpreter.hs:

module Language.BricksLang.Interpreter( 
  module Language.BricksLang.SyntaxTree , execBricks , makeLabelTable ) where
import Language.BricksLang.SyntaxTree 
import Control.Monad.Free
import Data.Char
import qualified Data.Map as M

---------------------------------------------------------------------------------------------------

execBricks :: Free Bricks () -> IO ()
execBricks program = runBricks ([], M.fromList (makeLabelTable program)) program

---------------------------------------------------------------------------------------------------
--ラベルテーブル作成
---------------------------------------------------------------------------------------------------

makeLabelTable :: Free Bricks a -> [(String, Free Bricks a)]
makeLabelTable (Pure _) = [] 
makeLabelTable (Impure (BricksLabel a n)) = (a, n) : makeLabelTable n
makeLabelTable (Impure (BricksPush _ n)) = makeLabelTable n
makeLabelTable (Impure (BricksPop n)) = makeLabelTable n
makeLabelTable (Impure (BricksPutChar n)) = makeLabelTable n
makeLabelTable (Impure (BricksPutInt n)) = makeLabelTable n
makeLabelTable (Impure (BricksAdd n)) = makeLabelTable n
makeLabelTable (Impure (BricksEq n)) = makeLabelTable n
makeLabelTable (Impure (BricksThrow _ n)) = makeLabelTable n
makeLabelTable (Impure (BricksGoto _ n)) = makeLabelTable n

---------------------------------------------------------------------------------------------------
--Bricks-langインタプリタ実行
---------------------------------------------------------------------------------------------------

type BricksState a = ([Int], M.Map String (Free Bricks a))

---------------------------------------------------------------------------------------------------

runBricks :: BricksState a -> Free Bricks a ->  IO a

-- Push
runBricks (xs, m) (Impure (BricksPush x n)) = runBricks ((x:xs), m) n

-- Pop
runBricks ([], m) (Impure (BricksPop n)) 
  = error "[Bricks-lang runtime error] `Pop` couldn't run because stack is empty"
runBricks ((_:xs), m) (Impure (BricksPop n)) = runBricks (xs, m) n

--PutChar
runBricks ([], _) (Impure (BricksPutChar n)) 
  = error "[Bricks-lang runtime error] `PutChar` couldn't run because stack is empty"
runBricks st@((x:_), m) (Impure (BricksPutChar n)) = putChar (chr x) >> runBricks st n

--PutInt
runBricks ([], _) (Impure (BricksPutInt n)) 
  = error "[Bricks-lang runtime error] `PutInt` couldn't run becaouse stack is empty"
runBricks st@((x:_), m) (Impure (BricksPutInt n)) = (putStr.show) x >> runBricks st n

--Label ・・・何もしない
runBricks st (Impure (BricksLabel _ n)) = runBricks st n

--Throw
runBricks _ (Impure (BricksThrow m _)) = error $ "[Bricks-lang runtime error] EXCEPTION : " ++ m

--Goto
runBricks st@((0:_), m) (Impure (BricksGoto l _)) = callNext $ M.lookup l m
  where
  callNext Nothing = error $ "[Bricks-lang runtime error] `Goto` couldn't find label `" ++ l ++ "`"
  callNext (Just n) =  runBricks st n
runBricks st (Impure (BricksGoto _ n)) = runBricks st n

--Add
runBricks ((x:y:xs), m) (Impure (BricksAdd n)) = runBricks ((x + y:xs) ,m) n
runBricks _ (Impure (BricksAdd _)) = 
  error $ "[Bricks-kang runtime error] `Add` couldn't run becaouse stack is empty"

--Eq
runBricks (xs@(x:y:_), m) (Impure (BricksEq n)) = runBricks ((eq x y:xs) ,m) n
  where eq x y = if x == y then 0 else 1
runBricks _ (Impure (BricksEq _)) = 
  error $ "[Bricks-kang runtime error] `Add` couldn't run becaouse stack is empty"

-- ...Pure
runBricks _ (Pure x) = return x

テストプログラム:

module Test.Interpreter() where
import Language.BricksLang.Interpreter

main = execBricks $ do
  --Loop開始定形処理
  bPush 3 --Loop回数
  bPush 1
  bPush 1
  bLabel "Loop"
  bPop
  bPop

  --主処理
  bPush 66
  bPush 65
  bPutChar --A
  bPop
  bPutChar --B
  bPop

  --Loop終了定形処理
  bPush (-1)
  bAdd
  bPush 0
  bEq
  bPush (-1)
  bAdd
  bGoto "Loop" --Gotoはスタックの一番上の要素が 0 の時だけ実行される
  
  --Loop開始定形処理
  bPush 3 --Loop回数
  bPush 1
  bPush 1
  bLabel "Loop2"
  bPop
  bPop

  --主処理
  bPush 68
  bPush 67
  bPutChar --C
  bPop
  bPutChar --D
  bPop

  --Loop終了定形処理
  bPush (-1)
  bAdd
  bPush 0
  bEq
  bPush (-1)
  bAdd
  bGoto "Loop2"

実行結果：

ABABABCDCDCD

とゆーわけで、楽しい時間ありがとうございましたーm(__)m

いつだってInfinity

Infinityの頭文字はIです。

即ち、無限大の愛です。
なんでも無いです忘れてください。

今回もちょいと軽めの話をしましょう。

Haskellの特徴として、遅延評価に加えて、正規形と見なされる制約に「弱頭部正規形」を採用しているという特徴があります。
これは「無限の長さを持つリスト」を定義できる。という事です。Haskellerなら常識ですね。

さて、ここで一つ問題を解いてみましょう、引数が無限リストだった場合Trueを返す関数 isInfinity :: [a] -> Bool を実装してください。

・・・・・・

はい、 そんなプログラムは作れません。
ちゃんと考えるの面倒臭いのでやってないですけど、プログラムの停止性問題あたりを使って厳密に説明できそうです。

さて、無限の長さを持つシーケンスから一つ一つ値を取り出していくような関数を考えましょう。
この関数は、シーケンスの値を永遠に出力し続けます。引数は無限リストである事が前提なので基底部(base case)は不要です。

module Main where

main :: IO ()
main = outputSeq [1..]

outputSeq :: Show a => [a] -> IO ()
outputSeq (x:xs) = putStrLn ("Value = " ++ (show x)) >> outputSeq xs

実行結果：

Value = 1
Value = 2
Value = 3
Value = 4
Value = 5
Value = 6
Value = 7

...

しかし、この関数に有限リスト（例えば[1..6]）を与えた場合、パターンマッチでエラーになってしまいます。

Value = 1
Value = 2
Value = 3
Value = 4
Value = 5
Value = 6
Main.hs: Main.hs:8:1-68: Non-exhaustive patterns in function outputSeq

最低限パターンエラーはマズイという事で、以下のようにエラーメッセージを出すという手も無い事は無いです。

outputSeq :: Show a => [a] -> IO ()
outputSeq [] = error "outputSeq: argument is not infinite list"
outputSeq (x:xs) = putStrLn ("Value = " ++ (show x)) >> outputSeq xs

でもこれ、リストの要素数が100,000,000とか1,000,000,000だった場合、リストの最後尾に辿り着くまでエラーに気づく事ができないので、ぶっちゃけ話にならないです。かといって、予め無限リストかどうか確認するのは、先に上げたとおり不可能ですし...

なんつぅか、そもそもｶｺﾜﾙｲ...

では、もうちょっとマイルドな方法で、引数にcycle関数を適用して強制的に無限リストにするとかどうでしょうか。

outputSeq :: Show a => [a] -> IO ()
outputSeq arg = f $ cycle arg
  where f (x:xs) = putStrLn ("Value = " ++ (show x)) >> outputSeq xs

確かにこれでエラーにはならなくなったけど、引数に対してcycle関数を使うのは、当初outputSeq関数にやらせたかった事では無いのでやはりスマートでは無いです。
とにかくですね、この関数を呼び出すプログラマさんには、明示的に無限の長さを持つリストを渡して欲しいのですよ。なんとかならんでしょうか。

えー...

うん、まー、別に悩むことは無いですね。
今我々が使っている言語はHaskellですし。

InfList.hs

module InfList(
  List,
  fromList,
  toList,
  map,
  take,
  head,
  tail,
  zip,
  zipWith) where

import qualified Prelude as PRE
import Prelude (($))

data List a = List [a]
instance PRE.Functor List where
  fmap = map

fromList :: [a] -> List a
fromList x = List $ PRE.cycle x

toList :: List a -> [a]
toList (List x) = x

map :: (a -> b) -> List a -> List b
map f (List x) = List $ PRE.map f x

take :: PRE.Int -> List a -> [a]
take i (List x) = PRE.take i x

head :: List a -> a
head (List x) = PRE.head x

tail :: List a -> List a
tail (List x) = List $ PRE.tail x

zip :: List a -> List b -> List (a, b)
zip (List x) (List y) = List $ PRE.zip x y

zipWith :: (a -> b -> c) -> List a -> List b -> List c
zipWith f (List x) (List y) = List $ PRE.zipWith f x y

そうです。常に無限リストになるような型を作ってしまうわけですね。

Listのデータコンストラクタはエクスポートしていないので、必然的にfromList関数で値を生成する必要があります、fromList関数は受け取ったリストにcycle関数を適用してからList型にして、返すのでこのモジュールをインポートして作成したList型の値は無限リストである事が保証されるというワケですねー。

module Main where
import qualified InfList as INF

main :: IO ()
main = outputSeq $ INF.fromList [1..6]

outputSeq :: Show a => INF.List a -> IO ()
outputSeq arg = putStrLn ("Value = " ++ (show . INF.head) arg) >> outputSeq (INF.tail arg)

結果的には同じことですが、こうする事で呼び出し元が無限リストを渡すという事を強く意識するようになります。
「うっかり有限リスト渡したら内部でcycleされて予想外の動作になっちまった！！」

という事故が防げるわけですね。

もしかしたら今回のInfListみたいな型って、ブログ主が知らないだけで、既にあるかもしれないですが・・・まぁ、Haskellで設計する場合の思考法の一つとして、参考になれば幸いでつ。
でわでわ。