Skip to content

Instantly share code, notes, and snippets.

@jmikkola
Last active October 28, 2018 04:41
Show Gist options
  • Save jmikkola/95e3a5eb4a5b60cbc8eab17f99152a59 to your computer and use it in GitHub Desktop.
Save jmikkola/95e3a5eb4a5b60cbc8eab17f99152a59 to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment