A "stepped" free monad that can fast-forward to resume a job, saves state between steps

Main.hs

{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE DeriveFunctor    #-}
{-# LANGUAGE FlexibleContexts #-}
module Main
    ( main
    ) where


-------------------------------------------------------------------------------
import           Control.Monad       (void)
import           Control.Monad.Free
import           Control.Monad.Loops (iterateUntil)
-------------------------------------------------------------------------------


-- | This is an attempt at a Job monad that can do the following things:
-- 1. It can express a sequential list of steps.
-- 2. Given a StepNo it can "fast forward" to that step in order to resume.
-- 3. It automatically keeps the StepNo up-to-date between steps and "saves" the job.
main :: IO ()
main = runJobM initJob process
  where
    -- Start on step 3. should skip into the first loop at step 3, then loop 2 more times, then run step 4
    initJob = Job Three 0


-------------------------------------------------------------------------------
-- Free Monad
-------------------------------------------------------------------------------


data StepNo = One
            | Two
            | Three
            | Four
            deriving (Show, Eq)


data Job = Job
  { stepNo :: StepNo
  , loops  :: Int
  } deriving (Show)


process :: JobM IO ()
process = void $ do
  _ <- step One one
  _ <- iterateUntil loopedThrice $ do
    _ <- step Two two
    step Three three
  step Four four
  where
    loopedThrice = (>= 3) . loops
    one j = j <$ putStrLn "one"
    two j = j <$ putStrLn "two"
    three j = do
      putStrLn "three"
      pure j { loops = succ (loops j)}
    four j = j <$ putStrLn "four"


data JobF m next = Step StepNo (Job -> m Job) (Job -> next) deriving (Functor)


type JobM m = Free (JobF m)


step :: StepNo -> (Job -> m Job) -> JobM m Job
step sn f = liftF (Step sn f id)


-------------------------------------------------------------------------------
-- Interpreter
-------------------------------------------------------------------------------


runJobM :: Job -> JobM IO () -> IO ()
runJobM _ (Pure a) = pure a
runJobM j1 (Free (Step sn f next)) = do
  if stepNo j1 == sn
     then do
       j2 <- f j1
       let j3 = case getStep (next j2) of
             Nothing -> j2
             Just ns -> j2 { stepNo = ns}
       save j3
       runJobM j3 (next j3)
     else fastForward
  where
    fastForward = runJobM j1 (next j1)
    getStep (Free (Step x _ _))  = Just x
    getStep (Pure _)             = Nothing
    save j = putStrLn ("Save: " ++ show j)