How to use Free Monad

freemonad.hs

{-# LANGUAGE DeriveFunctor, FlexibleInstances, FlexibleContexts #-}

import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.State
import qualified Control.Monad.Free as F
import qualified Data.Foldable as DF
import Prelude hiding (head,last)

{-
 -  ベースにするデータ構造をFunctorで定義する。
 -  Monadインターフェースを与えるのがFreeモナド。
 -  実装したい機能はFreeモナドに乗せた状態で作成する。
 -}

data ListF a = Nil | Node a (ListF a)
    deriving (Functor, Show)

instance DF.Foldable ListF where
    foldr f v Nil         = v
    foldr f v (Node x xs) = x `f` DF.foldr f v xs

type List a = F.Free ListF a

empty :: List a
empty = F.liftF Nil

singleton :: a -> List a
singleton a = F.liftF $ Node a Nil

cons :: a -> List a -> List a
cons a (F.Free xs) = F.Free (Node (F.Pure a) xs)
cons a (F.Pure x)  = cons a (singleton x)

head :: List a -> a
head = F.iter (\(Node x _) -> x)

last :: List a -> a
last = F.iter f
    where
    f (Node x Nil) = x
    f (Node _ xs)  = f xs

fromList :: [a] -> List a
fromList = foldr cons empty

sum1 :: Num a => List a -> a
sum1 = F.iter f
    where
    f Nil         = 0
    f (Node x xs) = x + f xs

sum2 :: Num a => List a -> a
sum2 = DF.foldl' (+) 0

sum3 :: Num a => List a -> a
sum3 = DF.foldl1 (+)

sum4 :: (Num a, Show a) => List a -> a
sum4 xs = head $ flip execStateT 0 $ do
    DF.forM_ xs $ \x -> do
        n <- get
        put (x + n)

filterEven :: (Integral a, Eq a) => List a -> List (Maybe a)
filterEven xs = runMaybeT $ do
    x <- lift xs
    if x `mod` 2 == 0
        then return x
        else fail ""