Created
September 16, 2012 11:53
-
-
Save gintenlabo/3732116 to your computer and use it in GitHub Desktop.
Procedural Haskell Sample
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| import qualified Data.Foldable as F | |
| import Data.Foldable (Foldable) | |
| import Control.Monad | |
| import Control.Monad.Trans | |
| import Control.Applicative | |
| -- for main | |
| import System.Random | |
| data Proc' r a = Return r | Break | Continue | Transitional a | |
| instance Monad (Proc' r) where | |
| return = Transitional | |
| Transitional a >>= f = f a | |
| Return r >>= _ = Return r | |
| Break >>= _ = Break | |
| Continue >>= _ = Continue | |
| instance Functor (Proc' r) where | |
| fmap f x = do { a <- x; return $ f a } | |
| newtype ProcT r m a = ProcT { fromProcT :: m (Proc' r a) } | |
| instance Monad m => Functor (ProcT r m) where | |
| fmap f (ProcT x) = ProcT $ liftM (fmap f) x | |
| instance Monad m => Monad (ProcT r m) where | |
| return = ProcT . return . Transitional | |
| ProcT x >>= f = ProcT $ do | |
| p <- x | |
| case p of | |
| Transitional a -> fromProcT $ f a | |
| proc -> return $ fmap (\x -> undefined) proc | |
| fail s = ProcT $ do | |
| r <- fail s | |
| return $ Return r | |
| instance Monad m => Applicative (ProcT r m) where | |
| pure = return | |
| v <*> x = do { f <- v; f <$> x } | |
| instance MonadPlus m => MonadPlus (ProcT r m) where | |
| mzero = ProcT mzero | |
| ProcT a `mplus` ProcT b = ProcT $ a `mplus` b | |
| instance MonadTrans (ProcT r) where | |
| lift = ProcT . liftM Transitional | |
| instance MonadIO m => MonadIO (ProcT r m) where | |
| liftIO = lift . liftIO | |
| runProcT :: (Monad m) => ProcT r m a -> m r | |
| runProcT (ProcT x) = do | |
| p <- x | |
| case p of | |
| Return a -> return a | |
| _ -> fail "function: no return value given" | |
| runProcT_ :: (Monad m) => ProcT () m a -> m () | |
| runProcT_ (ProcT x) = x >> return () | |
| returnWith :: (Monad m) => r -> ProcT r m a | |
| returnWith = ProcT . return . Return | |
| return_ :: (Monad m) => ProcT () m a | |
| return_ = returnWith () | |
| catchBreak :: (Monad m) => ProcT r m a -> ProcT r m () | |
| catchBreak suite = ProcT $ do | |
| proc <- fromProcT suite | |
| return $ case proc of | |
| Break -> Transitional () | |
| proc' -> fmap (const ()) proc' | |
| break_ :: (Monad m) => ProcT r m () | |
| break_ = ProcT $ return Break | |
| catchContinue :: (Monad m) => ProcT r m a -> ProcT r m () | |
| catchContinue suite = ProcT $ do | |
| proc <- fromProcT suite | |
| return $ case proc of | |
| Continue -> Transitional () | |
| proc' -> fmap (const ()) proc' | |
| continue_ :: (Monad m) => ProcT r m () | |
| continue_ = ProcT $ return Continue | |
| type Proc r = ProcT r IO | |
| runProc :: (MonadIO m) => Proc r a -> m r | |
| runProc = liftIO . runProcT | |
| runProc_ :: (MonadIO m) => Proc () a -> m () | |
| runProc_ = liftIO . runProcT_ | |
| forEach :: (Foldable t, Monad m) => t a -> (a -> ProcT r m b) -> ProcT r m () | |
| forEach xs f = | |
| catchBreak $ do | |
| F.forM_ xs $ \x -> | |
| catchContinue $ f x | |
| loop :: (Monad m) => ProcT r m b -> ProcT r m () | |
| loop suite = | |
| catchBreak $ do | |
| forever $ do | |
| catchContinue $ do | |
| suite | |
| -- 使用例 | |
| -- find 関数がこんなに手続き的に！ | |
| findIf :: (Foldable t) => t a -> (a -> Bool) -> Maybe a | |
| findIf xs pred = runProcT $ do | |
| forEach xs $ \x -> do | |
| when (pred x) $ | |
| returnWith x | |
| mzero -- なくてもよい | |
| -- 上記関数のモナド版も手続き的に書けてる | |
| findIfM :: (Foldable t, Monad m) => t a -> (a -> m Bool) -> m (Maybe a) | |
| findIfM xs pred = runProcT $ do | |
| forEach xs $ \x -> do | |
| cond <- lift $ pred x | |
| when cond $ | |
| returnWith $ Just x | |
| returnWith Nothing | |
| main :: IO () | |
| main = runProc_ $ do | |
| num <- liftIO $ do | |
| putStr "Enter a number (greater than 0): " | |
| readIO =<< getLine :: IO Int | |
| unless (num > 0) $ do | |
| liftIO $ putStrLn "It appears not to be greater than 0..." | |
| return_ | |
| loop $ do | |
| n <- liftIO $ randomRIO (1, num) | |
| when (n == 7) $ do | |
| liftIO $ putStrLn "Lucky Seven!" | |
| continue_ | |
| liftIO $ print n | |
| when (n == 1) $ do | |
| break_ | |
| liftIO $ putStrLn "Bye!" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment