Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# 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
--------------------------------------------------
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment