{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Prompt
  ( Prompt,
    prompt,
    choice,
    string,
    help,
    compact,
  )
where

import Data.Char (isSpace)
import Data.List.NonEmpty qualified as N
import Data.Maybe (fromJust, isNothing)
import System.IO (hFlush, stdout)
import Text.Printf (printf)
import Text.Read (readMaybe)

data Prompt a where
  Choice :: Bool -> Maybe (a -> String) -> String -> N.NonEmpty a -> Prompt a
  String :: Bool -> Maybe (String -> String) -> String -> [String] -> Prompt String

string :: String -> [String] -> Prompt String
string = String False Nothing

choice :: String -> N.NonEmpty a -> Prompt a
choice = Choice False Nothing

-- TODO add `help`
help :: (a -> String) -> Prompt a -> Prompt a
help h (Choice c _ q as) = Choice c (Just h) q as
help h (String c _ q as) = String c (Just h) q as

-- TODO add `compact`
--
-- @topic prompt
compact :: Prompt a -> Prompt a
compact (Choice _ h' q as) = Choice True h' q as
compact (String _ h' q as) = String True h' q as

class Promptable a where
  toString :: a -> String
  fromString :: String -> Maybe a

instance Promptable String where
  toString = id
  fromString = Just

prompt :: (Eq a, Promptable a) => Prompt a -> IO a
prompt p@(Choice c h' q as) = do
  -- TODO add `help`
  --
  -- @topic prompt
  let p' = String c Nothing q (map toString (N.toList as))
  a' <- fromString <$> prompt p'
  if isNothing a' || not (a' `elem` (map Just (N.toList as)))
    then prompt p
    else pure (fromJust a')
prompt p@(String _ _ q as) = do
  if null as
    then printf "%s " q
    else do
      printf "%s\n" q
      mapM_ (\(n, a) -> printf "[%d] %s\n" n a) (zip [1 :: Int ..] as)
      printf "Your choice? [default: %s] " (head as)
  hFlush stdout
  a <- strip <$> getLine
  if null as
    then pure a
    else case readMaybe a of
      Just n ->
        case drop (n - 1) as of
          [] -> prompt p
          (a : _) -> pure a
      Nothing ->
        if null a
          then pure (head as)
          else pure a

strip :: String -> String
strip = stripEnd . stripStart

stripStart :: String -> String
stripStart = dropWhile isSpace

stripEnd :: String -> String
stripEnd = reverse . stripStart . reverse