Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Free monad, interpreter handles exceptions, convert to Either
#!/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
--------------------------------------------------
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment