effects.hs

{-# LANGUAGE DeriveFunctor #-}

-- This needs the 'free' package installed in order to build

import Control.Monad (when)
import Control.Monad.Free (Free (..))
import System.IO (hFlush, stdout)

main :: IO ()
main = runIOOp exampleProgram

exampleProgram :: Free (IOOp String) ()
exampleProgram = do
  write "enter quit to exit, help to list commands\n"
  runStateOp  inputLoop
  write "done\n"

inputLoop :: Free (StateOp String) ()
inputLoop = do
  p <- sGetPrompt
  sWrite p
  text <- sRead
  handleText text

handleText :: String -> Free (StateOp String) ()
handleText text
  | text == ""     = inputLoop
  | text == "quit" = return () -- sEnd
  | text == "help" = do
      showHelp
      inputLoop
  | startsWith "i" text = do
      updateIndent (tail text)
      inputLoop
  | text == "set prompt" = do
      updatePrompt
      inputLoop
  | otherwise = do
      sWrite "invalid\n"
      inputLoop

updateIndent :: String -> Free (StateOp String) ()
updateIndent text = do
  idt <- sGetIndent
  when (text == "+") (sSetIndent (idt + 1))
  when (text == "-") (sSetIndent (idt - 1))
  return ()

updatePrompt :: Free (StateOp String) ()
updatePrompt = do
  sWrite "enter a new prompt: "
  p <- sRead
  sSetPrompt p

startsWith :: (Eq a) => [a] -> [a] -> Bool
startsWith [] _ = True
startsWith _ [] = False
startsWith (a:as) (b:bs) = a == b && startsWith as bs

showHelp :: Free (StateOp String) ()
showHelp = mapM_ (sWrite . (++ "\n")) opts
  where opts =
          [ "quit: exit"
          , "help: show this help"
          , "i+: increase indent"
          , "i-: decrease indent"
          , "set prompt: after hitting enter, write the new prompt to use"
          ]





sEnd :: Free (StateOp a) ()
sEnd = Free $ SEnd

sRead :: Free (StateOp a) String
sRead = Free $ SRead Pure

sWrite :: a -> Free (StateOp a) ()
sWrite s = Free $ SWrite s (Pure ())

sPut :: State -> Free (StateOp a) ()
sPut st = Free $ SPut st (Pure ())

sGet :: Free (StateOp a) State
sGet = Free $ SGet Pure

sModifyState :: (State -> State) -> Free (StateOp a) ()
sModifyState f = do
  st <- sGet
  sPut (f st)

sGetIndent :: Free (StateOp a) Int
sGetIndent = indent <$> sGet

sSetIndent :: Int -> Free (StateOp a) ()
sSetIndent i = sModifyState (\st -> st { indent = i })

sGetPrompt :: Free (StateOp a) String
sGetPrompt = prompt <$> sGet

sSetPrompt :: String -> Free (StateOp a) ()
sSetPrompt p = sModifyState (\st -> st { prompt = p })




runStateOp :: Free (StateOp String) () -> Free (IOOp String) ()
runStateOp program =
  let startState = State { indent = 0, prompt = "> " }
  in runState startState program

runState :: State -> Free (StateOp String) () -> Free (IOOp String) ()
runState st (Free prog) = do
  -- uncomment to enable debugging:
  --write (show st ++ "\n")
  case prog of
    SEnd -> end
    SRead f -> do
      line <- inputLn
      runState st (f line)
    SWrite s next -> do
      write (addIndent (indent st) s)
      runState st next
    SPut st' next -> do
      runState st' next
    SGet f -> do
      runState st (f st)
runState _ (Pure x) = return x


addIndent :: Int -> String -> String
addIndent n s = (take n $ repeat ' ') ++ s

data State = State { indent :: Int, prompt :: String }
  deriving (Show)

data StateOp b next
  = SEnd
  | SRead (String -> next)
  | SWrite b next
  | SPut State next
  | SGet (State -> next)
  deriving (Functor)


write :: a -> Free (IOOp a) ()
write s = Free $ Write s (Pure ())

inputLn :: Free (IOOp a) String
inputLn = Free $ Read Pure

end :: Free (IOOp a) ()
end = Free EndProgram

data IOOp b next
  = EndProgram
  | Read (String -> next)
  | Write b next
  deriving (Functor)

runIOOp :: Free (IOOp String) () -> IO ()
runIOOp (Free op) = case op of
  EndProgram -> return ()
  Read f -> do
    line <- getLine
    runIOOp (f line)
  Write s nextOp -> do
    putStr s
    hFlush stdout
    runIOOp nextOp
runIOOp (Pure a) = return a