diff --git a/prompt-hs.cabal b/prompt-hs.cabal --- a/prompt-hs.cabal +++ b/prompt-hs.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: prompt-hs -version: 1.0.1.0 +version: 1.0.2.0 synopsis: A user-friendly, dependently-typed library for asking your users questions description: A library making use of the terminal package to prompt users for answers in a CLI context. . diff --git a/src/System/Prompt.hs b/src/System/Prompt.hs --- a/src/System/Prompt.hs +++ b/src/System/Prompt.hs @@ -40,6 +40,7 @@ promptYesNoWithDefault, promptChoice, promptChoiceFromSet, + promptMultipleChoice, -- * Data Chooseable (..), @@ -151,27 +152,69 @@ ChoiceInstructionNormal -> "You can type to search, or use the arrow keys. Press enter to select." ChoiceInstructionNoOptionSelected -> "No option selected. Try expanding your filter with backspace to see more options." +-- | Gets the text which will be displayed to the user for a given instruction. +instructionTextMulti :: ChoiceInstruction -> Text +instructionTextMulti = \case + ChoiceInstructionNormal -> "You can type to search, or use the arrow keys. Press enter to select/deselect, and ctrl+enter to confirm." + ChoiceInstructionNoOptionSelected -> "No options match this search. Try expanding your filter with backspace to see more options." + +class IsPromptChoiceState a where + ipcsGetNumberOfOptions :: a -> Int + ipcsGetNumberOfFilteredOptions :: a -> Int + data PromptChoiceState (requirement :: SRequirement) (a :: Type) = PromptChoiceState { pcsConfirmation :: Confirmation, pcsFilter :: Text, pcsInstruction :: ChoiceInstruction, pcsOptions :: NonEmpty (PerRequirement requirement a), pcsFilteredOptions :: [PerRequirement requirement a], - pcsSelectedOption :: Maybe (PerRequirement requirement a) + pcsHoveredOption :: Maybe (PerRequirement requirement a) } +instance IsPromptChoiceState (PromptChoiceState requirement a) where + ipcsGetNumberOfOptions = length . pcsOptions + ipcsGetNumberOfFilteredOptions = length . pcsFilteredOptions + +data PromptMultipleChoiceState (a :: Type) = PromptMultipleChoiceState + { pmcsFilter :: Text, + pmcsInstruction :: ChoiceInstruction, + pmcsOptions :: NonEmpty a, + pmcsFilteredOptions :: [a], + pmcsHoveredOption :: Maybe a, + pmcsSelectedOptions :: [a] + } + +instance IsPromptChoiceState (PromptMultipleChoiceState a) where + ipcsGetNumberOfOptions = length . pmcsOptions + ipcsGetNumberOfFilteredOptions = length . pmcsFilteredOptions + _pcsFilter :: Lens' (PromptChoiceState requirement a) Text _pcsFilter = lens pcsFilter \s x -> s {pcsFilter = x} +_pmcsFilter :: Lens' (PromptMultipleChoiceState a) Text +_pmcsFilter = lens pmcsFilter \s x -> s {pmcsFilter = x} + _pcsInstruction :: Lens' (PromptChoiceState requirement a) ChoiceInstruction _pcsInstruction = lens pcsInstruction \s x -> s {pcsInstruction = x} +_pmcsInstruction :: Lens' (PromptMultipleChoiceState a) ChoiceInstruction +_pmcsInstruction = lens pmcsInstruction \s x -> s {pmcsInstruction = x} + _pcsFilteredOptions :: Lens' (PromptChoiceState requirement a) [PerRequirement requirement a] _pcsFilteredOptions = lens pcsFilteredOptions \s x -> s {pcsFilteredOptions = x} -_pcsSelectedOption :: Lens' (PromptChoiceState requirement a) (Maybe (PerRequirement requirement a)) -_pcsSelectedOption = lens pcsSelectedOption \s x -> s {pcsSelectedOption = x} +_pmcsFilteredOptions :: Lens' (PromptMultipleChoiceState a) [a] +_pmcsFilteredOptions = lens pmcsFilteredOptions \s x -> s {pmcsFilteredOptions = x} +_pcsHoveredOption :: Lens' (PromptChoiceState requirement a) (Maybe (PerRequirement requirement a)) +_pcsHoveredOption = lens pcsHoveredOption \s x -> s {pcsHoveredOption = x} + +_pmcsHoveredOption :: Lens' (PromptMultipleChoiceState a) (Maybe a) +_pmcsHoveredOption = lens pmcsHoveredOption \s x -> s {pmcsHoveredOption = x} + +_pmcsSelectedOptions :: Lens' (PromptMultipleChoiceState a) [a] +_pmcsSelectedOptions = lens pmcsSelectedOptions \s x -> s {pmcsSelectedOptions = x} + data PromptTextState (requirement :: SRequirement) = PromptTextState { ptsConfirmation :: Confirmation, ptsCurrentInput :: Text, @@ -235,6 +278,30 @@ liftIO . withTerminal . runTerminalT $ promptChoiceInternal Proxy prompt (initialPromptChoiceStateFromSet confirmation $ NE.nub set) +-- | Ask the user to choose zero-to-many of the constructors of a sum type. +-- +-- @ +-- data Colour = Red | Green | Blue deriving (Bounded, Enum, Eq, Show) +-- +-- instance Chooseable Colour where +-- showChooseable = Data.Text.pack . show +-- +-- main :: IO () +-- main = do +-- favouriteColours <- promptMultipleChoice (Proxy :: Proxy Colour) $ "What are your favourite colours?" +-- print favouriteColours +-- @ +promptMultipleChoice :: + (Chooseable a, Eq a, MonadIO m) => + -- | Proxy of type you want to get back + Proxy a -> + -- | What should the prompt say? (You need not add a space to the end of this text; one will be added) + Text -> + m [a] +promptMultipleChoice pxy prompt = + liftIO . withTerminal . runTerminalT $ + promptMultipleChoiceInternal pxy prompt initialPromptMultipleChoiceState + -- | Ask the user to enter text. -- -- The answer is stripped of leading and trailing whitespace. @@ -309,7 +376,7 @@ pcsInstruction = ChoiceInstructionNormal, pcsOptions = universeChooseableNE, pcsFilteredOptions = NE.toList universeChooseableNE, - pcsSelectedOption = Just initialSelectionChooseable + pcsHoveredOption = Just initialSelectionChooseable } initialPromptChoiceStateFromSet :: @@ -324,9 +391,22 @@ pcsInstruction = ChoiceInstructionNormal, pcsOptions = options, pcsFilteredOptions = NE.toList options, - pcsSelectedOption = Just initialSelectionChooseableItem + pcsHoveredOption = Just initialSelectionChooseableItem } +initialPromptMultipleChoiceState :: + (Chooseable a) => + PromptMultipleChoiceState a +initialPromptMultipleChoiceState = + PromptMultipleChoiceState + { pmcsFilter = "", + pmcsInstruction = ChoiceInstructionNormal, + pmcsOptions = universeChooseableNE, + pmcsFilteredOptions = NE.toList universeChooseableNE, + pmcsHoveredOption = initialSelectionChooseable, + pmcsSelectedOptions = [] + } + promptChoiceInternal :: (MonadInput m, Renderable m requirement a) => Proxy a -> @@ -337,6 +417,16 @@ linesRendered <- renderPromptChoicePrompt prompt s awaitEvent >>= handlePromptChoiceEvent prompt linesRendered s +promptMultipleChoiceInternal :: + (MonadInput m, Renderable m 'SRequired a) => + Proxy a -> + Text -> + PromptMultipleChoiceState a -> + m [a] +promptMultipleChoiceInternal _ prompt s = do + linesRendered <- renderPromptMultipleChoicePrompt prompt s + awaitEvent >>= handlePromptMultipleChoiceEvent prompt linesRendered s + promptTextInternal :: (MonadColorPrinter m, MonadFormattingPrinter m, MonadInput m, MonadScreen m) => PromptTextState requirement -> @@ -355,28 +445,37 @@ m Int renderPromptChoicePrompt prompt s = do renderPromptLine prompt - linesRendered <- renderOptionLines s + linesRendered <- renderChoiceOptionLines s renderSummaryLine s linesRendered - renderInstructionLine - renderFilterLine + renderInstructionLine instructionText $ pcsInstruction s + renderFilterLine $ pcsFilter s pure $ linesRendered + 4 - where - renderInstructionLine = withAttributes [italic] . putTextLn . instructionText $ pcsInstruction s - renderFilterLine = do - withAttributes [bold, foreground magenta] $ putText "> " - putText $ pcsFilter s - flush +-- | Renders the prompt for the user and returns the number of lines output +renderPromptMultipleChoicePrompt :: + (Renderable m 'SRequired a) => + Text -> + PromptMultipleChoiceState a -> + m Int +renderPromptMultipleChoicePrompt prompt s = do + renderPromptLine prompt + linesRendered <- renderMultipleChoiceOptionLines s + renderSummaryLine s linesRendered + renderCurrentSelectionsLine s + renderInstructionLine instructionTextMulti $ pmcsInstruction s + renderFilterLine $ pmcsFilter s + pure $ linesRendered + 5 + renderPrompt :: (MonadColorPrinter m, MonadFormattingPrinter m) => Text -> m () renderPrompt = withAttributes [bold, foreground blue] . putText . (<> " ") renderPromptLine :: (MonadColorPrinter m, MonadFormattingPrinter m) => Text -> m () renderPromptLine = withAttributes [bold, foreground blue] . putTextLn -renderSummaryLine :: (Renderable m requirement a) => PromptChoiceState requirement a -> Int -> m () +renderSummaryLine :: (IsPromptChoiceState s, MonadColorPrinter m, MonadFormattingPrinter m) => s -> Int -> m () renderSummaryLine s numberOfOptionsRendered = do - let nAll = length $ pcsOptions s - nFiltered = length $ pcsFilteredOptions s + let nAll = ipcsGetNumberOfOptions s + nFiltered = ipcsGetNumberOfFilteredOptions s withAttributes [italic, foreground cyan] . putTextLn $ T.pack (show nFiltered) <> "/" @@ -385,38 +484,89 @@ <> T.pack (show numberOfOptionsRendered) <> " shown." -renderOptionLines :: +renderCurrentSelectionsLine :: (ChooseableItem a, MonadColorPrinter m, MonadFormattingPrinter m) => PromptMultipleChoiceState a -> m () +renderCurrentSelectionsLine s = do + withAttributes [italic, foreground cyan] $ putText "Current Selections: " + withAttributes [bold, italic, foreground cyan] + . putTextLn + . T.intercalate ", " + . fmap chooseableItemText + $ pmcsSelectedOptions s + +renderChoiceOptionLines :: forall requirement a m. (Renderable m requirement a) => PromptChoiceState requirement a -> m Int -renderOptionLines s = do - let (selectedOption, otherOptions) = getVisibleOptions s - case selectedOption of +renderChoiceOptionLines s = do + let (hoveredOption, otherOptions) = getVisibleChoiceOptions s + case hoveredOption of Just o -> withAttributes [bold, foreground yellow] . putTextLn . ("* " <>) $ chooseableItemText o Nothing -> pure () forM_ otherOptions (withAttributes [foreground yellow] . putTextLn . (" " <>) . chooseableItemText) - pure $ length otherOptions + maybe 0 (const 1) selectedOption + pure $ length otherOptions + maybe 0 (const 1) hoveredOption --- | Returns a maximum of 6 options, including the one currently selected as the first option. -getVisibleOptions :: +renderMultipleChoiceOptionLines :: + forall a m. + (Renderable m 'SRequired a) => + PromptMultipleChoiceState a -> + m Int +renderMultipleChoiceOptionLines s = do + let (hoveredOption, otherOptions) = getVisibleMultipleChoiceOptions s + case hoveredOption of + Just o -> withAttributes [bold, foreground yellow] . putTextLn . ("> " <>) . insertSelectedIndicator o $ chooseableItemText o + Nothing -> pure () + forM_ otherOptions (\o -> withAttributes [foreground yellow] . putTextLn . (" " <>) . insertSelectedIndicator o $ chooseableItemText o) + pure $ length otherOptions + maybe 0 (const 1) hoveredOption + where + insertSelectedIndicator :: a -> Text -> Text + insertSelectedIndicator o = + ( ( if o `elem` pmcsSelectedOptions s + then "[*] " + else "[ ] " + ) + <> + ) + +-- | Returns a maximum of 6 options, including the one currently hovered as the first option. +getVisibleChoiceOptions :: forall requirement a result. (result ~ PerRequirement requirement a, Eq result) => PromptChoiceState requirement a -> (Maybe result, [result]) -getVisibleOptions s = case pcsSelectedOption s of +getVisibleChoiceOptions s = case pcsHoveredOption s of Just o | o `elem` filteredOptions -> (Just o, take 5 $ filter (/= o) filteredOptions) _ -> (Nothing, take 6 filteredOptions) where maxNumberOfOptions :: Int maxNumberOfOptions = length $ pcsFilteredOptions s filteredOptions :: [result] - filteredOptions = take maxNumberOfOptions . dropWhile isNotSelectedOption . cycle $ pcsFilteredOptions s - isNotSelectedOption :: result -> Bool - isNotSelectedOption o = case pcsSelectedOption s of + filteredOptions = take maxNumberOfOptions . dropWhile isNotHoveredOption . cycle $ pcsFilteredOptions s + isNotHoveredOption :: result -> Bool + isNotHoveredOption o = case pcsHoveredOption s of Just target -> o /= target Nothing -> False +-- | Returns a maximum of 6 options, including the one currently hovered as the first option. +getVisibleMultipleChoiceOptions :: forall a. (Eq a) => PromptMultipleChoiceState a -> (Maybe a, [a]) +getVisibleMultipleChoiceOptions s = case pmcsHoveredOption s of + Just o | o `elem` filteredOptions -> (Just o, take 5 $ filter (/= o) filteredOptions) + _ -> (Nothing, take 6 filteredOptions) + where + maxNumberOfOptions :: Int + maxNumberOfOptions = length $ pmcsFilteredOptions s + filteredOptions :: [a] + filteredOptions = take maxNumberOfOptions . maybe id (\o -> dropWhile (/= o)) (pmcsHoveredOption s) . cycle $ pmcsFilteredOptions s + +renderInstructionLine :: (MonadFormattingPrinter m) => (a -> Text) -> a -> m () +renderInstructionLine instructionToText = withAttributes [italic] . putTextLn . instructionToText + +renderFilterLine :: (MonadFormattingPrinter m, MonadColorPrinter m) => Text -> m () +renderFilterLine f = do + withAttributes [bold, foreground magenta] $ putText "> " + putText f + flush + handlePromptChoiceEvent :: forall m requirement a. (Renderable m requirement a, MonadInput m) => @@ -435,15 +585,15 @@ Upwards -> goAgain $ s - { pcsSelectedOption = + { pcsHoveredOption = headViaNonEmpty $ drop 1 - . dropWhile (maybe (const False) (/=) (pcsSelectedOption s)) + . dropWhile (maybe (const False) (/=) (pcsHoveredOption s)) . cycle . reverse $ pcsFilteredOptions s } - Downwards -> goAgain $ s {pcsSelectedOption = headViaNonEmpty . snd $ getVisibleOptions s} + Downwards -> goAgain $ s {pcsHoveredOption = headViaNonEmpty . snd $ getVisibleChoiceOptions s} _ -> goAgain s BackspaceKey -> goAgain $ @@ -453,9 +603,9 @@ & _pcsInstruction %~ \case ChoiceInstructionNoOptionSelected -> ChoiceInstructionNormal currentInstruction -> currentInstruction - EnterKey -> case pcsSelectedOption s of + EnterKey -> case pcsHoveredOption s of Just o -> case pcsConfirmation s of - RequireConfirmation -> confirmSelection prompt o (goAgain s) + RequireConfirmation -> confirmSelection prompt o (chooseableItemText o) (goAgain s) DontConfirm -> do renderPrompt prompt withAttributes [bold, foreground yellow] . putTextLn $ chooseableItemText o @@ -474,6 +624,76 @@ goAgain :: PromptChoiceState requirement a -> m (PerRequirement requirement a) goAgain = promptChoiceInternal Proxy prompt +handlePromptMultipleChoiceEvent :: + forall m a. + (Renderable m 'SRequired a, MonadInput m) => + Text -> + Int -> + PromptMultipleChoiceState a -> + Either Interrupt Event -> + m [a] +handlePromptMultipleChoiceEvent prompt linesRendered s e = do + moveCursorUp (linesRendered - 1) + deleteLines linesRendered + case e of + Left Interrupt -> liftIO exitFailure + Right (KeyEvent key modifiers) -> case key of + ArrowKey direction -> case direction of + Upwards -> + goAgain $ + s + { pmcsHoveredOption = + headViaNonEmpty + $ drop 1 + . dropWhile (maybe (const False) (/=) (pmcsHoveredOption s)) + . cycle + . reverse + $ pmcsFilteredOptions s + } + Downwards -> goAgain $ s {pmcsHoveredOption = headViaNonEmpty . snd $ getVisibleMultipleChoiceOptions s} + _ -> goAgain s + BackspaceKey -> + goAgain $ + s + & _pmcsFilter %~ T.dropEnd 1 + & applyFilterMultiple + & _pmcsInstruction %~ \case + ChoiceInstructionNoOptionSelected -> ChoiceInstructionNormal + currentInstruction -> currentInstruction + EnterKey -> + confirmSelection + prompt + (pmcsSelectedOptions s) + ( if null (pmcsSelectedOptions s) + then "[nothing]" + else T.intercalate ", " . fmap chooseableItemText $ pmcsSelectedOptions s + ) + (goAgain s) + CharKey c + | c == ' ' -> + goAgain $ + s + & _pmcsSelectedOptions + %~ ( \opts -> case pmcsHoveredOption s of + Just hovered -> + if hovered `elem` opts + then filter (/= hovered) opts + else hovered : opts + Nothing -> opts + ) + CharKey c -> + if modifiers == mempty + then + if null (pmcsFilteredOptions s) + then goAgain $ s {pmcsInstruction = ChoiceInstructionNoOptionSelected} + else goAgain $ s & _pmcsFilter %~ flip T.snoc c & applyFilterMultiple + else goAgain s + _ -> goAgain s + _ -> goAgain s + where + goAgain :: PromptMultipleChoiceState a -> m [a] + goAgain = promptMultipleChoiceInternal Proxy prompt + handlePromptTextEvent :: (MonadColorPrinter m, MonadFormattingPrinter m, MonadInput m, MonadScreen m) => PromptTextState requirement -> @@ -500,8 +720,8 @@ _ -> promptTextInternal s _ -> promptTextInternal s --- | Applies the filter in `_pcsFilter` to set `_pcsOptions` and update `_pcsSelectedOption` --- if the previously selected option is no longer included in the filter. +-- | Applies the filter in `_pcsFilter` to set `_pcsOptions` and update `_pcsHoveredOption` +-- if the previously hovered option is no longer included in the filter. applyFilter :: (result ~ PerRequirement requirement a, ChooseableItem result, Eq result) => PromptChoiceState requirement a -> @@ -513,20 +733,38 @@ (NE.toList $ pcsOptions s) in s & _pcsFilteredOptions .~ newFilteredOptions - & _pcsSelectedOption %~ \case + & _pcsHoveredOption %~ \case Just o | o `elem` newFilteredOptions -> Just o _ -> headViaNonEmpty newFilteredOptions +-- | Applies the filter in `_pcsFilter` to set `_pcsOptions` and update `_pcsHoveredOption` +-- if the previously hovered option is no longer included in the filter. +applyFilterMultiple :: + (ChooseableItem a, Eq a) => + PromptMultipleChoiceState a -> + PromptMultipleChoiceState a +applyFilterMultiple s = + let newFilteredOptions = + filter + ((T.toLower (pmcsFilter s) `T.isInfixOf`) . T.toLower . chooseableItemText) + (NE.toList $ pmcsOptions s) + in s + & _pmcsFilteredOptions .~ newFilteredOptions + & _pmcsHoveredOption %~ \case + Just o | o `elem` newFilteredOptions -> Just o + _ -> headViaNonEmpty newFilteredOptions + confirmSelection :: - (ChooseableItem a, MonadColorPrinter m, MonadFormattingPrinter m, MonadInput m, MonadScreen m) => + (MonadColorPrinter m, MonadFormattingPrinter m, MonadInput m, MonadScreen m) => Text -> a -> + Text -> m a -> m a -confirmSelection prompt selection onCancel = do +confirmSelection prompt selection selectionText onCancel = do renderPromptLine prompt withAttributes [bold, foreground cyan] $ putText "You have chosen: " - withAttributes [bold, foreground yellow] $ putTextLn (chooseableItemText selection) + withAttributes [bold, foreground yellow] $ putTextLn selectionText withAttributes [italic] $ putTextLn "Press enter again to confirm, or escape to go back." e <- awaitEvent moveCursorUp 3 *> deleteLines 4 @@ -534,10 +772,10 @@ Left Interrupt -> liftIO exitFailure Right (KeyEvent EnterKey _) -> do renderPrompt prompt - withAttributes [bold, foreground yellow] $ putTextLn (chooseableItemText selection) + withAttributes [bold, foreground yellow] $ putTextLn selectionText pure selection Right (KeyEvent EscapeKey _) -> onCancel - _ -> confirmSelection prompt selection onCancel + _ -> confirmSelection prompt selection selectionText onCancel confirmTextInput :: forall m requirement.