Input.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}

module Cmt.IO.Input
    ( loop
    ) where

import ClassyPrelude

import Data.Map.Strict              (Map)
import System.Console.Terminal.Size (size, width)

import Cmt.IO.Git         (changed)
import Cmt.Parser.Options (parse)
import Cmt.Types.Config

type Choice = Map Int Text

prompt :: Text -> IO Text
prompt s = do
    putStr $ s <> " "
    hFlush stdout
    getLine

getWidth :: IO Int
getWidth = maybe 0 width <$> size

putName :: Text -> IO ()
putName name = putStrLn $ "\n" <> name <> ":"

listItem :: Int -> Text -> Text
listItem n o = tshow n <> ") " <> o

displayOptions :: Choice -> IO ()
displayOptions opts = do
    let parts = mapWithKey listItem opts
    let long = intercalate "   " parts
    maxLength <- getWidth
    if length long < maxLength
        then putStrLn long
        else sequence_ $ putStrLn <$> parts

choice :: Choice -> Int -> Maybe Text
choice opts chosen = lookup chosen opts

choiceGen :: [Text] -> Choice
choiceGen ts = mapFromList $ zip [1 ..] ts

options :: [Text] -> IO Text
options opts = do
    let opts' = choiceGen opts
    displayOptions opts'
    chosen <- parse <$> prompt ">"
    case chosen of
        Nothing -> options opts
        Just chosen' -> do
            let picked = catMaybes $ choice opts' <$> chosen'
            if null picked
                then options opts
                else pure $ intercalate ", " picked

multiLine :: [Text] -> IO [Text]
multiLine input = do
    value <- prompt ">"
    if null value && not (null input)
        then pure input
        else multiLine $ input ++ [value]

line :: IO Text
line = do
    value <- prompt ">"
    if null value
        then line
        else pure value

output :: Part -> IO Output
output (Part name Line)           = putName name >> (,) name <$> line
output (Part name (Options opts)) = putName name >> (,) name <$> options opts
output (Part name Lines)          = putName name >> (,) name <$> (unlines <$> multiLine [])
output (Part name Changed)        = putName name >> (,) name <$> (options =<< changed)

loop :: Config -> IO Outputs
loop (Config parts _) = mapFromList <$> traverse output parts