Skip to content

Instantly share code, notes, and snippets.

@kagamilove0707
Created September 15, 2013 05:38
Show Gist options
  • Save kagamilove0707/6568296 to your computer and use it in GitHub Desktop.
Save kagamilove0707/6568296 to your computer and use it in GitHub Desktop.
Freeモナドのスコット・エンコーディングによる実装ですー>ω< kazu-yamamoto氏のhttps://gist.github.com/kazu-yamamoto/4064634#file-gistfile1-hs-L76を参考にさせていただきましたのです(`・ω・´)
{-# LANGUAGE Rank2Types, DeriveFunctor, LambdaCase #-}
module Control.Monad.Free.Scott (($|), Free(..), free', pure', liftF) where
infixl 1 $|
($|) :: (a -> b) -> a -> b
f $| x = f x
-- Type
newtype Free f a = Free {
matchFree :: forall r. (f (Free f a) -> r) -- Free (f (Free f a))
-> (a -> r) -- Pure a
-> r }
-- Constructors
free' :: (f (Free f a)) -> Free f a
free' x = Free $ \f p-> f x
pure' :: a -> Free f a
pure' x = Free $ \f p-> p x
-- Instances
instance Functor f => Functor (Free f) where
fmap f x = matchFree x
$| (\y -> free' $ fmap (fmap f) y)
$| (\x'-> pure' $ f x')
instance Functor f => Monad (Free f) where
return x = pure' x
x >>= f = matchFree x
$| (\y -> free' $ fmap (>>= f) y)
$| (\x'-> f x')
-- Functions
liftF :: Functor f => f r -> Free f r
liftF = free' . fmap pure'
{-# LANGUAGE Rank2Types, DeriveFunctor, LambdaCase #-}
import Control.Monad.Free.Scott
import Test.QuickCheck (quickCheck)
type CharIO = Free CharActions
data CharActions a
= PutCh Char a
| GetCh (Char -> a)
deriving (Functor)
putCh :: Char -> CharIO ()
putCh c = liftF $ PutCh c ()
getCh :: CharIO Char
getCh = liftF $ GetCh id
runCharIO :: CharIO a -> IO ()
runCharIO x = matchFree x
$| (\case
PutCh c x'-> putChar c >> runCharIO x'
GetCh f -> getChar >>= runCharIO . f)
$| (\_-> return ())
echo :: CharIO ()
echo = do
getCh >>= putCh
echo
main = runCharIO echo
data Output a
= Print Char (Output a)
| Read (Output a)
| Return a
| EOF
deriving (Eq, Show)
toOutput :: CharIO a -> String -> Output a
toOutput x cs = matchFree x
$| (\case
PutCh c x'-> Print c (toOutput x' cs)
GetCh f
|null cs -> EOF
|otherwise -> Read $ toOutput (f $ head cs) $ tail cs)
$| (\x-> Return x)
copy :: String -> Output a
copy "" = EOF
copy (c:cs) = Read $ Print c $ copy cs
propEcho :: String -> Bool
propEcho s = toOutput echo s == copy s
test :: IO ()
test = quickCheck propEcho
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment