Created
July 10, 2020 08:38
-
-
Save SergeyStretovich/29e2b4d300dd469ae4477f23a99936e6 to your computer and use it in GitHub Desktop.
Freer monad - merge effect interpreters using freer-simple
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE LambdaCase #-} | |
{-# LANGUAGE MonoLocalBinds #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE ConstraintKinds #-} | |
{-# LANGUAGE RankNTypes #-} | |
{-# LANGUAGE Rank2Types #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
module Main where | |
import Data.Monoid | |
import Data.Functor | |
import Data.List | |
import Data.String | |
import Control.Natural (type (~>)) | |
import Control.Monad.Freer.Writer (Writer, tell,runWriter) | |
import Control.Monad.Freer | |
( | |
Eff | |
, LastMember | |
, Member | |
, interpret | |
, interpretM | |
, send | |
, run | |
, runM | |
) | |
data FileSystem r where | |
ReadFile :: FilePath -> FileSystem String | |
WriteFile :: FilePath -> String -> FileSystem () | |
readFile :: Member FileSystem effs => FilePath -> Eff effs String | |
readFile = send . ReadFile | |
writeFile :: Member FileSystem effs => FilePath -> String -> Eff effs () | |
writeFile pth = send . WriteFile pth | |
data AppError r where | |
Ensure :: Bool -> String -> AppError () | |
Fail :: String -> AppError () | |
ensure :: Member AppError effs => Bool -> String -> Eff effs () | |
ensure condition message = send $ Ensure condition message | |
fail :: Member AppError effs => String -> Eff effs () | |
fail = send . Fail | |
data ApState = ApState {filePath::String,fileText::String} deriving Show | |
data TestItem = Item { | |
pre :: String, | |
post :: String, | |
pathTI :: FilePath | |
} | |
data RunConfig = RunConfig { | |
environment :: String, | |
depth :: Integer, | |
pathRC :: FilePath | |
} | |
type FileSys r = (Member FileSystem r) | |
type AppFailure r = (Member AppError r) | |
interactor :: TestItem -> RunConfig -> (AppFailure r, FileSys r) => Eff r ApState | |
interactor item runConfig = do | |
let fullFilePath = pathRC (runConfig :: RunConfig) | |
Main.writeFile fullFilePath $ pre item <> post item | |
Main.fail "random error ~ its a glitch" | |
txt <- Main.readFile "C:\\Vids\\SystemDesign\\Wrong.txt" | |
pure $ ApState fullFilePath txt | |
fileSystemDocInterpreter :: Member (Writer [String]) effs => FileSystem ~> Eff effs | |
fileSystemDocInterpreter = | |
let | |
mockContents::String = "Mock File Contents" | |
in | |
\case | |
ReadFile path -> tell ["readFile: " <> show path] $> mockContents | |
WriteFile path str -> tell ["write file: " <> | |
show path <> | |
"\nContents:\n" <> | |
str] | |
errorDocInterpreter :: Member (Writer [String]) effs => AppError ~> Eff effs | |
errorDocInterpreter = \case | |
Ensure condition errMsg -> tell [if condition then "Ensure Check Passed" else ("Ensure Check Failed ~ " <> errMsg) ] | |
Fail errMsg -> tell ["Failure ~ " <> errMsg] | |
executeDocumented :: forall a. Eff '[FileSystem, AppError, Writer [String]] a | |
-> (a, [String]) | |
executeDocumented app = run $ runWriter | |
$ interpret errorDocInterpreter | |
$ interpret fileSystemDocInterpreter | |
$ app | |
main :: IO () | |
main = do | |
let ti = Item {pre="", post ="", pathTI =""} | |
let rc = RunConfig {environment ="", depth =1, pathRC ="C:\\Vids\\SystemDesign\\VidList.txt"} | |
let (apst,messages) = executeDocumented $ interactor ti rc | |
putStrLn $ show apst | |
mapM_ (\x->putStrLn x) messages | |
putStrLn "_" | |
{- | |
How can I merge effect interpreters when using a library like freer-simple? | |
https://stackoverflow.com/questions/52016576/how-can-i-merge-effect-interpreters-when-using-a-library-like-freer-simple | |
dependencies: | |
- base >= 4.7 && < 5 | |
- freer-simple | |
- natural-transformation | |
-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment