Free monad, interpreter handles exceptions, convert to Either

FreeMonad_Handle_Exception.hs

#!/usr/bin/env stack
{- stack
  script
  --resolver lts-10.0
  --package text
  --package protolude
  --package text
  --package containers
  --package free
  --package safe-exceptions
  --package mtl
  --package transformers
-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}

module Main where

import           Protolude hiding (throwIO, catch, State, runState)
import qualified Prelude -- only for DemoException's show
import qualified Data.Text as Txt
import qualified Data.Text.IO as Txt
import           Control.Monad.Free
import           Control.Monad.Free.TH
import           Control.Monad.Free.Church as C
import           Control.Monad.Trans.Except (throwE)
import           Control.Exception.Safe (catch, throwIO)  --NB Using safe exceptions to only catch async exceptions
import qualified Control.Monad.State.Strict as S


-- Example of a free monad for catching exceptions
-- DSL handles logic
-- Job must be able to run unconstrained IO
-- Example of church encoding
  

--------------------------------------------------
-- 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 free monad / DSL
--------------------------------------------------
data OpsF m next = OpRead (Text -> next)
                 | OpWrite Text next
                 | OpLog Text next
                 | OpRun Text (Text -> m Text) Text (Text -> next)
                 deriving (Functor)

makeFree ''OpsF
type Ops m = Free (OpsF m)
--------------------------------------------------


--------------------------------------------------
-- 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
               ]
  
  a <- runExceptT $ interpreterFile $ createDsl "test1" ioJobs
  print a

  ai <- runExceptT $ interpreterFile (C.improve $ createDsl "test1" ioJobs)
  print ai

  
  --------------------------------------------------
  -- Example in state, e.g. for testing
  --------------------------------------------------
  putText ""
  putText "-----------------"
  let stateJobs = [ Job "j1" testJob1
                  , Job "j2" testJob2
                  ]

  let t2 = createDsl "test2" stateJobs
  let st1 = TestState "0" []
  let b = S.runState (interpreterState t2) st1
  print b

  let bi = S.runState (interpreterState (C.improve $ createDsl "test2" stateJobs)) st1
  print bi


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

  let ci = S.runState (runExceptT . interpreterStateStack $ createDsl "test2" stateJobs) st1
  print ci
--------------------------------------------------


--------------------------------------------------
-- 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
--------------------------------------------------
--createDsl :: (Monad m) => Text -> [Job m] -> (Ops m) Text
createDsl :: (Monad m, MonadFree (OpsF m) a) => Text -> [Job m] -> a Text
createDsl initial jobs = do
  opLog "starting: "
  opWrite initial
  foldlM createJob "start" jobs

  where
    --createJob :: (Monad m) => Text -> Job m -> (Ops m) Text
    createJob :: (Monad m, MonadFree (OpsF m) a) => Text -> Job m -> a Text
    createJob 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 o of
    Pure a -> pure a

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

    (Free (OpWrite t n)) ->
      do
        liftIO $ Txt.writeFile "data.txt" t
        interpreterFile n
      `catch`
        handler ErrWrite
      
    (Free (OpRun name fn t n)) ->
      do
        r <- lift $ fn t
        interpreterFile $ n r
      `catch`
        handler (ErrRunning name)
      
    (Free (OpLog t n)) -> do
      liftIO $ 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 o of
    Pure a -> do
      modify (\s -> s { tstValue = a })
      tstValue <$> get

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

    (Free (OpWrite t n)) -> do
      S.modify (\s -> s { tstValue = t } )
      interpreterState n
      
    (Free (OpRun _ fn t n)) -> do
      r <- fn t
      interpreterState $ n r
      
    (Free (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 :: (Ops (S.State TestState)) Text -> ExceptT OpsError (S.State TestState) Text
interpreterStateStack o =
  case o of
    Pure a -> do
      modify (\s -> s { tstValue = a })
      tstValue <$> get

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

    (Free (OpWrite t n)) -> do
      S.modify (\s -> s { tstValue = t } )
      interpreterStateStack n
      
    (Free (OpRun _ fn t n)) -> do
      r <- lift $ fn t
      interpreterStateStack $ n r
      
    (Free (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
--------------------------------------------------