blob: 0548c80d506fbec6874d9ded57a77fa8edb80384 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-# 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`
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`
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
|
