learn-effects/app/Main.hs

module Main where

import Control.Monad.Freer
import Control.Monad.Freer.Error
-- import Control.Monad.Freer.Reader
import Control.Monad.Freer.State
import Control.Monad.Freer.TH
import Control.Monad.Freer.Writer
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.Text (pack, unpack)
import Data.Text.IO qualified as Text
import Debug.Trace
import System.IO hiding (readFile)
import Prelude hiding (readFile)

-- import Data.OpenUnion.Internal (FindElem, IfNotFound)

data UIO r where
  ReadUIO :: UIO String
  WriteUIO :: String -> UIO ()

-- readUIO :: Member UIO r => Eff r [String]
-- readUIO = send ReadUIO
--
-- writeUIO :: Member UIO r => String -> Eff r ()
-- writeUIO = send . WriteUIO

-- Above two definitions are equivalent to below TH invocation
makeEffect ''UIO

-- Our Program/AST
writeProgram :: Member UIO effs => String -> Eff effs ()
writeProgram = writeUIO

readProgram :: Member UIO effs => Eff effs String
readProgram = readUIO

data File r where
  ReadFile :: FilePath -> File String

-- readFile :: Member File effs => FilePath -> Eff effs String
-- readFile = send . ReadFile

-- Same as above
makeEffect ''File

interpretFileIO :: Eff '[File, UIO, IO] a -> Eff '[UIO, IO] a
interpretFileIO =
  interpretM
    ( \case
        ReadFile path -> do
          contents <- Text.readFile path
          return $ unpack contents
    )

-- interpretFilePure :: Member (State String) effs => forall a . Eff (File ': effs) a -> Eff effs a
-- The Natural transformation ~> hides the second type parameter of Eff.
-- type (~>) f g = forall x. f x -> g x
-- https://hackage.haskell.org/package/natural-transformation-0.4/docs/Control-Natural.html
interpretFilePure :: Member (State String) effs => Eff (File ': effs) ~> Eff effs
interpretFilePure =
  interpret
    ( \case
        ReadFile path -> do
          put $ "Trying to read file " <> path
          pure ""
    )

fileProgram :: Members '[UIO, File] effs => Eff effs ()
fileProgram = readFile "testfile.txt" >>= writeUIO

-- Interpretation/implementation using IO Monad
interpretInFile :: FilePath -> Eff '[UIO, IO] a -> Eff '[IO] a
interpretInFile path =
  interpretM
    ( \case
        WriteUIO msg -> Text.writeFile path $ pack msg
        ReadUIO -> do
          contents <- Text.readFile path
          return $ unpack contents
    )

interpretInIO :: Eff '[UIO, IO] a -> Eff '[IO] a
interpretInIO =
  interpretM
    ( \case
        WriteUIO msg -> putStrLn msg
        ReadUIO -> getLine
    )

interpretPure :: Members '[State String] effs => Eff (UIO ': effs) ~> Eff effs
interpretPure =
  interpret
    ( \case
        WriteUIO msg -> do
          -- Get initial state
          initialState <- get @String
          -- Append to the initial state
          put $ initialState <> msg
        ReadUIO -> get
    )

runInIO :: Eff '[UIO, IO] a -> IO a
runInIO = runM . interpretInIO

runInPure :: String -> Eff '[UIO, State String] a -> String
runInPure initialState = snd . run . runState initialState . interpretPure

runFileIO :: IO ()
runFileIO =
  -- interpretInIO . interpretFileIO $ fileProgram
  fileProgram
    & interpretFileIO
    & interpretInIO
    & runM

runFilePure :: String -> String
runFilePure initialState =
  -- snd . run . runState initialState . interpretPure . interpretFilePure $ fileProgram
  fileProgram
    & interpretFilePure
    & interpretPure
    & runState initialState
    & run
    & snd

runIO :: IO ()
runIO = runInIO $ readProgram >>= (\i -> writeProgram $ "Input was: " <> i)

runPure :: (String, String)
runPure = (readP, writeP)
  where
    readP = runInPure "Read State" readProgram
    writeP = runInPure "Initial State" $ writeProgram ": Run in PURE!!!!"

-- In the next 3 functions, we play around with reinterpret
runInPure2 :: [String] -> Eff '[UIO] w -> ([String], [String])
runInPure2 inputs req = do
  -- r :: ((w, [String]), [String])
  let r = run (runWriter (runState inputs (reinterpret2 go req)))
  -- let r = run (runState inputs (runWriter (reinterpret2 go req)))
  -- (snd . fst $ r, snd r)
  first snd r
  where
    go :: UIO v -> Eff '[State [String], Writer [String]] v
    -- go :: UIO v -> Eff '[Writer [String], State [String]] v
    go (WriteUIO msg) = traceM ("WriteUIO: " <> show msg) >> tell [msg]
    go ReadUIO =
      get >>= \case
        [] -> traceM "ReadUIO []: " >> pure "Empty List"
        l@(x : xs) -> put xs >> traceM ("ReadUIO: " <> show l) >> pure x

runInPure21 :: Int -> [String] -> Eff '[UIO] w -> ([String], Int)
runInPure21 input inputs req = do
  -- r :: ((w, [String]), Int)
  let r = run (runState input (runState inputs (reinterpret2 go req)))
  first snd r
  where
    go :: UIO v -> Eff '[State [String], State Int] v
    go (WriteUIO msg) = traceM ("WriteUIO: " <> show msg) >> get @Int >>= (\x -> put [show x])
    go ReadUIO =
      get >>= \case
        [] -> traceM "ReadUIO []: " >> pure "Empty List"
        l@(x : xs) -> put xs >> traceM ("ReadUIO: " <> show l) >> pure x

runInPure3 :: [String] -> Eff '[UIO] w -> [String]
runInPure3 inputs req =
  snd . fst $
    run (runWriter (runState inputs (runError (reinterpret3 go req))))
  where
    go :: UIO v -> Eff '[Error (), State [String], Writer [String]] v
    go (WriteUIO msg) = tell [msg]
    go ReadUIO =
      get >>= \case
        [] -> error "not enough lines"
        (x : xs) -> put xs >> pure x

main :: IO ()
main = do
  -- runIO
  print runPure
  putStrLn $ runFilePure "Initial State"
  runFileIO