1{-# LANGUAGE GADTs #-} 2{-# LANGUAGE KindSignatures #-} 3{-# LANGUAGE TemplateHaskell #-} 4{-# LANGUAGE FlexibleContexts #-} 5module Main where 6 7import Control.Monad 8import Control.Monad.Fail as Fail 9import Control.Monad.Free 10import Control.Monad.Free.TH 11import Control.Monad.IO.Class 12import Control.Monad.Trans.Instances () 13import Control.Monad.Trans.Maybe 14import qualified Data.Foldable as F 15import Text.Read.Compat (readMaybe) 16 17-- | A data type representing basic commands for a retriable eDSL. 18data RetryF next where 19 Output :: String -> next -> RetryF next 20 Input :: Read a => (a -> next) -> RetryF next 21 WithRetry :: Retry a -> (a -> next) -> RetryF next 22 Retry :: RetryF next 23 24-- | Unfortunately this Functor instance cannot yet be derived 25-- automatically by GHC. 26instance Functor RetryF where 27 fmap f (Output s x) = Output s (f x) 28 fmap f (Input g) = Input (f . g) 29 fmap f (WithRetry block g) = WithRetry block (f . g) 30 fmap _ Retry = Retry 31 32-- | The monad for a retriable eDSL. 33type Retry = Free RetryF 34 35-- | Simple output command. 36makeFreeCon 'Output 37 38-- | Get anything readable from input. 39makeFreeCon 'Input 40 41-- | Force retry command (retries innermost retriable block). 42makeFreeCon 'Retry 43 44makeFreeCon_ 'WithRetry 45-- | Run a retryable block. 46withRetry :: MonadFree RetryF m => 47 Retry a -- ^ Computation to retry. 48 -> m a -- ^ Computation that retries until succeeds. 49 50-- The following functions have been made available: 51-- 52-- output :: MonadFree RetryF m => String -> m () 53-- input :: (MonadFree RetryF m, Read a) => m a 54-- withRetry :: MonadFree RetryF m => Retry a -> m a 55-- retry :: MonadFree RetryF m => m a 56 57-- | We can run a retriable program in any MonadIO. 58runRetry :: (MonadFail m, MonadIO m) => Retry a -> m a 59runRetry = iterM run 60 where 61 run :: (MonadFail m, MonadIO m) => RetryF (m a) -> m a 62 63 run (Output s next) = do 64 liftIO $ putStrLn s 65 next 66 67 run (Input next) = do 68 s <- liftIO getLine 69 case readMaybe s of 70 Just x -> next x 71 Nothing -> Fail.fail "invalid input" 72 73 run (WithRetry block next) = do 74 -- Here we use 75 -- runRetry :: MonadIO m => Retry a -> MaybeT (m a) 76 -- to control failure with MaybeT. 77 -- We repeatedly run retriable block until we get it to work. 78 Just x <- runMaybeT . F.msum $ repeat (runRetry block) 79 next x 80 81 run Retry = Fail.fail "forced retry" 82 83-- | Sample program. 84test :: Retry () 85test = do 86 n <- withRetry $ do 87 output "Enter any positive number: " 88 n <- input 89 when (n <= 0) $ do 90 output "The number should be positive." 91 retry 92 return n 93 output $ "You've just entered " ++ show (n :: Int) 94 95main :: IO () 96main = runRetry test 97