clanki-1.2.5: src/Input.hs

module Input(getUserChoice, getUserChoiceStr, sameLinePrompt) where
import Text.Printf(printf)
import Data.Maybe(isJust)
import System.IO(hSetBuffering, BufferMode(NoBuffering, LineBuffering), stdin, stdout, hFlush)
import Display
import Control.Monad(when)
import Data.Char(toUpper)

keys :: [String]
keys = map (:[]) ['A' .. 'Z']

getUserChoice :: (Display a) => [a] -> IO (Maybe a)
getUserChoice = getChoiceWithKeys . zip keys

getUserChoiceStr :: [String] -> IO (Maybe String)
getUserChoiceStr = getChoiceWithKeysStr . zip keys

getChoiceWithKeysStr :: [(String, String)] -> IO (Maybe String)
getChoiceWithKeysStr choices = do
    hSetBuffering stdin NoBuffering
    hSetBuffering stdout NoBuffering
    printf $ repKeysAndValues choices
    input <- userInputLetter
    let action = lookup input choices
    hSetBuffering stdin LineBuffering
    hSetBuffering stdout LineBuffering
    when (isJust action) $ printf "\n"
    return action

choicesToStringPairs :: (Display a) => [(String, a)] -> [(String, String)]
choicesToStringPairs choicePairs = [(fst pair, display $ snd pair) | pair <- choicePairs]

repKeysAndValues :: [(String, String)] -> String
repKeysAndValues choices = unlines [key ++ ")" ++ " " ++ a | (key, a) <- choices]


getChoiceWithKeys :: (Display a) => [(String, a)] -> IO (Maybe a)
getChoiceWithKeys choices = do
    hSetBuffering stdin NoBuffering
    hSetBuffering stdout NoBuffering
    printf $ repKeysAndValues $ choicesToStringPairs choices
    input <- userInputLetter
    let action = lookup input choices
    hSetBuffering stdin LineBuffering
    hSetBuffering stdout LineBuffering
    when (isJust action) $ printf "\n"

    return action

userInputLetter :: IO String
userInputLetter = do
    input <- fmap ((:[]) . toUpper) getChar
    putStrLn ""
    return input

sameLinePrompt :: String -> IO String
sameLinePrompt prompt = do
    printf prompt
    hFlush stdout
    getLine