chore: add `createdAt` tag

1 files changed, 85 insertions, 0 deletions

diff --git a/app/Prompt.hs b/app/Prompt.hs
new file mode 100644
index 0000000..0548c80
--- /dev/null
+++ b/app/Prompt.hs
@@ -0,0 +1,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