skeleton使ってみた

gistfile1.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MonadSkeletonTest where
import Control.Monad.Skeleton
import Control.Monad.State

data MyProgBase a where
  PrintString :: MyProgBase ()
  GetString :: MyProgBase String
  PutString :: String -> MyProgBase ()
 
type MyProg = Skeleton MyProgBase

instance MonadState String MyProg where
  get = getString
  put = putString

----

printString :: MyProg ()
printString = bone PrintString

getString :: MyProg String
getString = bone GetString

putString :: String -> MyProg ()
putString = bone . PutString

runMyProg :: String -> MyProg a -> IO a
runMyProg s p = evalStateT (interpret run p) s
  where 
    run :: MyProgBase a -> StateT String IO a
    run GetString = get 
    run PrintString = get >>= liftIO . putStrLn 
    run (PutString s) = put s

interpret :: forall instr m b. Monad m => (forall a. instr a -> m a) -> Skeleton instr b -> m b
interpret f p = run $ unbone p
  where
    run :: MonadView instr (Skeleton instr) a -> m a
    run (Return x) = return x
    run (v :>>= n) = f v >>= run . unbone . n

----

test :: MyProg String
test = do
  x <- getString
  put "Hoge"  
  printString
  y <- get
  put "Piyo"  
  printString
  z <- get
  return $ x ++ " - " ++ y ++ " - " ++ z