content: module Console
    ( Console
    , exitSuccess'
    , getLine'
    , putStrLn'
    , runConsole
    , runConsoleM
    , runConsolePure
    , runConsolePureM
    ) where
  
  import Data.Function ((&))
  import System.Exit (exitSuccess)
  
  import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret3, run, runM, send)
  import Control.Monad.Freer.Error (Error, runError, throwError)
  import Control.Monad.Freer.State (State, get, put, runState)
  import Control.Monad.Freer.Writer (Writer, runWriter, tell)
  
  
  -------------------------------------------------------------------------------
                            -- Effect Model --
  -------------------------------------------------------------------------------
  data Console s where
    PutStrLn    :: String -> Console ()
    GetLine     :: Console String
    ExitSuccess :: Console ()
  
  putStrLn' :: Member Console r => String -> Eff r ()
  putStrLn' = send . PutStrLn
  
  getLine'  :: Member Console r => Eff r String
  getLine' = send GetLine
  
  exitSuccess' :: Member Console r => Eff r ()
  exitSuccess' = send ExitSuccess
  
  -------------------------------------------------------------------------------
                       -- Effectful Interpreter Simple --
  -------------------------------------------------------------------------------
  runConsole :: Eff '[Console, IO] a -> IO a
  runConsole = runM . interpretM (\case
    PutStrLn msg -> putStrLn msg
    GetLine -> getLine
    ExitSuccess -> exitSuccess)
  
  -------------------------------------------------------------------------------
                          -- Pure Interpreter Simple --
  -------------------------------------------------------------------------------
  runConsolePure :: [String] -> Eff '[Console] w -> [String]
  runConsolePure inputs req = snd . fst $
      run (runWriter (runState inputs (runError (reinterpret3 go req))))
    where
      go :: Console v -> Eff '[Error (), State [String], Writer [String]] v
      go (PutStrLn msg) = tell [msg]
      go GetLine = get >>= \case
        [] -> error "not enough lines"
        (x:xs) -> put xs >> pure x
      go ExitSuccess = throwError ()
  
  -------------------------------------------------------------------------------
                       -- Effectful Interpreter for Deeper Stack --
  -------------------------------------------------------------------------------
  runConsoleM :: forall effs a. LastMember IO effs
              => Eff (Console ': effs) a -> Eff effs a
  runConsoleM = interpretM $ \case
    PutStrLn msg -> putStrLn msg
    GetLine -> getLine
    ExitSuccess -> exitSuccess
  
  -------------------------------------------------------------------------------
                       -- Pure Interpreter for Deeper Stack --
  -------------------------------------------------------------------------------
  runConsolePureM
    :: forall effs w
     . [String]
    -> Eff (Console ': effs) w
    -> Eff effs (Maybe w, [String], [String])
  runConsolePureM inputs req = do
      ((x, inputs'), output) <- reinterpret3 go req
        & runError & runState inputs & runWriter
      pure (either (const Nothing) Just x, inputs', output)
    where
      go :: Console v
         -> Eff (Error () ': State [String] ': Writer [String] ': effs) v
      go (PutStrLn msg) = tell [msg]
      go GetLine = get >>= \case
        [] -> error "not enough lines"
        (x:xs) -> put xs >> pure x
      go ExitSuccess = throwError ()
  