Free Monadの使用例

free-monad-examples.hs

{-# LANGUAGE DeriveFunctor, FlexibleContexts, UndecidableInstances #-}
import Control.Monad.Free
import Control.Monad (void)
import Control.Monad.Identity
import Data.Void

import Test.QuickCheck

-- Free Monadの使用例


newtype D next = D (next, next) deriving Functor
-- 二分木
-- a >> bで木aの全ての葉を"木bを枝化したもの"に置換
type BinaryTree = Free D

runBinaryTree1 :: Show a => (a -> a -> a) -> BinaryTree a -> IO a
runBinaryTree1 f m = case m of
                          Pure x -> (putStrLn $ "leaf is: " ++ show x) >> return x
                          Free (D (t, u)) -> do
                            x <- runBinaryTree1 f t
                            y <- runBinaryTree1 f u
                            let result = f x y
                            putStrLn $ show x ++ " * " ++ show y ++ " is: " ++ show result
                            return result

bappend :: BinaryTree a -> BinaryTree a -> BinaryTree a
bappend n m = Free $ D (n, m)

binaryTreeEx :: Int -> BinaryTree Int
binaryTreeEx n = if n > 5 then return 1 else bappend (binaryTreeEx (n+1)) (binaryTreeEx (n+2))


-- リストと同型 (Pure ()がnil、Free (x, xs)でcons) 参考: http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html?m=1
-- (>>)で結合
type MyList a = Free ((,) a) ()
myListToList :: Free ((,) a) b -> [a]
myListToList m = case m of
                      Pure _ -> []
                      Free (x, xs) -> x:myListToList xs

mySingleton :: a -> MyList a
mySingleton x = Free (x, Pure ())

myListEx :: MyList Int
myListEx = replicateM_ 5 $ do
  mySingleton 2
  mySingleton 1
  mySingleton 6
  mySingleton 2

type Fix a = Free a Void

-- 無限リスト
type InfiniteList a = Free ((,) a) Void

infiniteListEx :: InfiniteList Int
infiniteListEx = forever $ do
  mySingleton 2
  mySingleton 1
  mySingleton 1

infiniteListEx' :: Int -> InfiniteList Int
infiniteListEx' n = do
  mySingleton n
  infiniteListEx' (succ n)

-- 自然数  (>>)で加算
type MyNatural = Free Identity ()

myZero :: MyNatural
myZero = Pure ()

mySucc :: MyNatural -> MyNatural
mySucc n = Free $ Identity n

myNaturalToInt :: MyNatural -> Int
myNaturalToInt m = case m of
                        Pure _ -> 0
                        Free (Identity m') -> succ $ myNaturalToInt m'

data TwoColor a next = Black a next | White a next deriving Functor
-- 2色のリストのようなものになる [Either a a]みたいな
type TwoColorList a = Free (TwoColor a) ()

run2ColorLs :: Show a => TwoColorList a -> IO ()
run2ColorLs ds = case ds of
                      Pure _ -> return ()
                      Free (Black x next) -> putStrLn ("black: " ++ show x) >> run2ColorLs next
                      Free (White x next) -> putStrLn ("white: " ++ show x) >> run2ColorLs next

-- 引数を幾つ取るか分からない函数 0個(定数)の場合もある
type FuncFromVector a = Free ((->) a)

-- ベクトルを添え字(Int)から要素への函数で表す
-- それへの適用が以下
applyToVector :: FuncFromVector a b -> (Int -> a) -> b
applyToVector = app 0
  where
    app i m vect = case m of
                        Pure x -> x
                        Free f -> app (succ i) (f (vect i)) vect

-- 標準入力からベクトルを受け取る
applyToYourVector :: (Read a) => FuncFromVector a b -> IO b
applyToYourVector f = case f of
                           Pure x -> return x
                           Free f' -> do
                             l <- getLine
                             applyToYourVector (f' (read l))
-- 腹ぺこ函数
hungry :: FuncFromVector a Void
hungry = Free (\x -> hungry)

instance (Arbitrary a, Arbitrary (f (Free f a))) => Arbitrary (Free f a) where
  arbitrary = oneof [fmap Pure arbitrary, fmap Free arbitrary]

main :: IO ()
main = do
  samples <- sample' (arbitrary :: Gen (MyList Int))
  print $ map myListToList samples
  print $ take 5 $ myListToList $ infiniteListEx' 5