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