A port of https://gist.github.com/andrevdm/4d1625e6504e3f1fef9ee9fbc1298b34 to the Operational Monad

OperationalVersion.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs, Rank2Types #-}

module OperationalVersion (main) where

import           Protolude hiding (throwIO, catch, State, runState)
import qualified Prelude -- only for show
import qualified Data.Text as Txt
import qualified Data.Text.IO as Txt
import           Control.Monad.Operational
import           Control.Monad.Trans.Except (throwE)
import           Control.Exception.Safe (catch, throwIO)
import qualified Control.Monad.State.Strict as S


-- Example of the operational monad for catching exceptions
-- DSL handles logic
-- Job must be able to run unconstrained IO
  

--------------------------------------------------
-- Custom exception
--------------------------------------------------
newtype DemoException = DemoException Text

instance Show DemoException where
  show (DemoException s) = Txt.unpack s
  
instance Exception DemoException
--------------------------------------------------


--------------------------------------------------
-- Possible errors
--------------------------------------------------
data OpsError = ErrRead Text
              | ErrWrite Text
              | ErrLogging Text
              | ErrRunning Text Text
              deriving (Show, Eq)
--------------------------------------------------


--------------------------------------------------
-- The operational monad / DSL
--------------------------------------------------
data OpsI m a where
    OpRead  :: OpsI m Text
    OpWrite :: Text -> OpsI m ()
    OpLog   :: Text -> OpsI m ()
    OpRun   :: Text -> (Text -> m Text) -> Text -> OpsI m Text

type Ops m a = Program (OpsI m) a

opRead = singleton OpRead
opWrite = singleton . OpWrite
opLog = singleton . OpLog
opRun n f p = singleton (OpRun n f p)

--------------------------------------------------


--------------------------------------------------
-- Job that must be run
--------------------------------------------------
data Job m = Job { jobName :: Text
                 , jobFn :: Text -> m Text
                 }
--------------------------------------------------

  
--------------------------------------------------
main :: IO ()
main = do
  --------------------------------------------------
  -- Example in IO with exception
  --------------------------------------------------
  let ioJobs = [ Job "j1" ioJob1
               , Job "j2" ioJob2
               , Job "j3" ioJob3
               ]
  
  let t1 = mainLogic "test1" ioJobs
  a <- runExceptT $ interpreterFile t1
  print a
  
  --------------------------------------------------
  -- Example in state, e.g. for testing
  --------------------------------------------------
  putText ""
  putText "-----------------"
  let t2 = mainLogic "test2" [ Job "j1" testJob1
                             , Job "j2" testJob2
                             ]
  let st1 = TestState "0" []
  let b = S.runState (interpreterState t2) st1
  print b

  --------------------------------------------------
  -- Example in state (stacked State and ExceptT), e.g. for testing
  --------------------------------------------------
  putText ""
  putText "-----------------"
  let c = S.runState (runExceptT $ interpreterStateStack t2) st1
  print c
--------------------------------------------------


--------------------------------------------------
-- Core logic of how jobs are run, traced etc
-- This is run in the free monad
-- Builds the syntax tree that the interpreter will run
--------------------------------------------------
mainLogic :: (Monad m) => Text -> [Job m] -> (Ops m) Text
mainLogic initial jobs = do
  opLog "starting: "
  opWrite initial
  foldlM runJob "start" jobs

  where
    runJob :: (Monad m) => Text -> Job m -> (Ops m) Text
    runJob id (Job name fn) = do
      opLog $ "running job: " <> name

      prev <- opRead
      r <- opRun name fn prev
      opWrite r
      
      opLog $ "  = " <> r
      opLog "  ----"

      pure $ id <> "," <> name
--------------------------------------------------


--------------------------------------------------
-- Interpreter for the free monad using
--  a file to load and store the data to/from
--  Runs the IO jobs, which can throw exceptions
--  Catch exceptions and use throwE to make them a Left in the ExceptT
--------------------------------------------------
interpreterFile :: (Ops IO) Text -> ExceptT OpsError IO Text
interpreterFile o =
  case view o of
    Return a -> pure a

    OpRead :>>= n ->
      do
        r <- liftIO $ Txt.readFile "data.txt"
        interpreterFile $ n r
      `catch`
        handler ErrRead

    OpWrite t :>>= n ->
      do
        liftIO $ Txt.writeFile "data.txt" t
        interpreterFile $ n ()
      `catch`
        handler ErrWrite
      
    OpRun name fn t :>>= n ->
      do
        r <- lift $ fn t
        interpreterFile $ n r
      `catch`
        handler (ErrRunning name)
      
    OpLog t :>>= n -> do
      putText $ "log: " <> t
      interpreterFile $ n ()

  where
    handler :: (Monad m) => (Text -> OpsError) -> SomeException -> ExceptT OpsError m Text
    handler ope e = throwE . ope $ show e  -- Convert exception to a Left
--------------------------------------------------


--------------------------------------------------
-- IO jobs to be run
--------------------------------------------------
ioJob1 :: Text -> IO Text
ioJob1 v = do
  putText "in job1"
  pure $ "1:" <> v

ioJob2 :: Text -> IO Text
ioJob2 v = do
  putText "in job2"
  void . throwIO $ DemoException "oops"
  pure $ "2:" <> v

ioJob3 :: Text -> IO Text
ioJob3 v = do
  putText "in job3"
  pure $ "3:" <> v
--------------------------------------------------



-- =============================================================================================================================
--  State example, e.g. for testing the free monad DSL
-- =============================================================================================================================


--------------------------------------------------
-- Data type used as the state for the state monad
--------------------------------------------------
data TestState = TestState { tstValue :: Text
                           , tstLog :: [Text]
                           }
                           deriving (Show, Eq)
--------------------------------------------------


--------------------------------------------------
-- Interpreter for the free monad using
--  the state monad as storage
--------------------------------------------------
interpreterState :: (Ops (S.State TestState)) Text -> (S.State TestState) Text
interpreterState o =
  case view o of
    Return a -> do
      modify (\s -> s { tstValue = a })
      tstValue <$> get

    OpRead :>>= n -> do
      st <- S.get 
      interpreterState $ n (tstValue st)

    OpWrite t :>>= n -> do
      S.modify (\s -> s { tstValue = t } )
      interpreterState $ n ()
      
    OpRun _ fn t :>>= n -> do
      r <- fn t
      interpreterState $ n r
      
    OpLog t :>>= n -> do
      S.modify (\(TestState s ls) -> TestState s $ ls <> [t])
      interpreterState $ n ()
--------------------------------------------------



--------------------------------------------------
-- Interpreter for the free monad using
--  the state monad as storage. Using stacked
--  State and ExceptT
--------------------------------------------------
--interpreterStateStack :: (MonadExcept OpsError m) => (Ops (S.State TestState)) Text -> m (S.State TestState) Text
interpreterStateStack :: (Ops (S.State TestState)) Text -> ExceptT OpsError (S.State TestState) Text
interpreterStateStack o =
  case view o of
    Return a -> do
      modify (\s -> s { tstValue = a })
      tstValue <$> get

    OpRead :>>= n -> do
      st <- S.get 
      interpreterStateStack $ n (tstValue st)

    OpWrite t :>>= n -> do
      S.modify (\s -> s { tstValue = t } )
      interpreterStateStack $ n ()
      
    OpRun _ fn t :>>= n -> do
      r <- lift $ fn t
      interpreterStateStack $ n r

    OpLog t :>>= n -> do
      S.modify (\(TestState s ls) -> TestState s $ ls <> [t])
      interpreterStateStack $ n ()
--------------------------------------------------


--------------------------------------------------
-- Jobs for the tests
--------------------------------------------------
testJob1 :: Text -> (S.State TestState) Text
testJob1 v =
  pure $ "1:" <> v

testJob2 :: Text -> (S.State TestState) Text
testJob2 v =
  pure $ "2:" <> v
--------------------------------------------------