diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for brick-dropdownmenu + +## 0.1.0 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Demo.hs b/app/Demo.hs new file mode 100644 --- /dev/null +++ b/app/Demo.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Brick +import Brick.Focus +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit +import Brick.Widgets.DropDownMenu +import Brick.Widgets.List (listAttr, listSelectedAttr) +import Control.Category ((>>>)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text +import Graphics.Vty (defAttr, blue, white, Event(EvKey), Key(..), Modifier(..)) +import Lens.Micro +import Lens.Micro.TH + +data Name = MenuBar + | FileMenu | FileOpen | FileQuit + | EditMenu | EditCut + | HelpMenu | HelpAbout + | Editor + | About + deriving (Eq, Ord, Show) +data State = State { + _menu :: DropDownMenu State Name +, _edit :: Editor Text Name +, _status :: String +, _focus :: FocusRing Name +} +makeLenses ''State + +draw s = mconcat + [ about $ focusGetCurrent (s^.focus) == Just About + , [ withFocusRing (s^.focus) renderDropDownMenu (s^.menu) + , translateBy (Location (0, 1)) $ + vBox [ withFocusRing (s^.focus) (renderEditor (txt . Data.Text.unlines)) (s^.edit) + , str $ s^.status, str " " + ] + ] + ] + +about True = [centerLayer $ borderWithLabel (str "About this program") info] + where + info = padLeftRight 2 $ padTopBottom 1 $ + str "This is a demo of the dropdownmenu widget." + <=> str " " + <=> showCursor About (Location (0, 0)) (str "Press ESC to continue") +about _ = [] + + +handleEvent :: State -> BrickEvent Name e -> EventM Name (Next State) +handleEvent s (VtyEvent e) = + fromMaybe accordingToFocus $ + handleGlobalDropDownMenuEvent s menu (setFocus MenuBar) e + where + accordingToFocus = case focusGetCurrent $ s^.focus of + Just MenuBar -> if e == EvKey KEsc [] && not (isDropDownMenuOpen (s^.menu)) + then continue $ s & focus %~ focusSetCurrent Editor + else handleDropDownMenuEvent s menu (setFocus MenuBar) e + Just Editor -> case e of + EvKey KEsc [] -> continue . setFocus MenuBar $ s + _ -> continue =<< handleEventLensed s edit handleEditorEvent e + Just About -> case e of + EvKey KEsc [] -> continue . setFocus Editor $ s + _ -> continue s + Nothing -> continue s +handleEvent s _ = continue s + +setFocus n = focus %~ focusSetCurrent n + +exitMenu x = menu %~ closeDropDownMenu + >>> focus %~ focusSetCurrent x + +msg t = set status t >>> exitMenu Editor >>> continue + +aboutDialog = exitMenu About >>> continue + +menuD = + [ ("File", FileMenu, Just (EvKey (KChar 'f') [MMeta]), + [ ("Open", FileOpen, Just (EvKey (KChar 'o') [MCtrl]), msg "Not implemented") + , ("Quit", FileQuit, Just (EvKey (KChar 'q') [MCtrl]), halt)]) + , ("Edit", EditMenu, Just (EvKey (KChar 'e') [MMeta]), + [("Cut", EditCut, Just (EvKey (KChar 'x') [MCtrl]), msg "This could cut something")]) + , ("Help", HelpMenu, Just (EvKey (KChar 'h') [MMeta]), + [("About this program", HelpAbout, Nothing, aboutDialog)]) + ] + +demo = defaultMain + App { + appChooseCursor = showFirstCursor +, appDraw = draw +, appAttrMap = const attrs +, appStartEvent = pure +, appHandleEvent = handleEvent +} + +main = demo State { + _menu = dropDownMenu MenuBar menuD +, _edit = editor Editor Nothing (pack "You can change this text.\nPress ESC to go to the menu.") +, _status = "started." +, _focus = focusRing [Editor, About, MenuBar] +} + +attrs = attrMap defAttr + [ (menuAttr, white `on` blue) + , (menuSelectedAttr, blue `on` white) + , (listAttr, white `on` blue) + , (listSelectedAttr, blue `on` white) + ] diff --git a/brick-dropdownmenu.cabal b/brick-dropdownmenu.cabal new file mode 100644 --- /dev/null +++ b/brick-dropdownmenu.cabal @@ -0,0 +1,76 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a585b898b2e28775a391fa1d72334d9dfcd5f96391fc26eb258a9a0fc13d9a3d + +name: brick-dropdownmenu +version: 0.1.0 +synopsis: A drop-down menu widget for brick. +description: A simple drop-down menu widget for the declarative text user interface library brick. + Each submenu and menu item can have an associated global key binding. +category: Graphics +homepage: https://github.com/mlang/brick-dropdownmenu#readme +bug-reports: https://github.com/mlang/brick-dropdownmenu/issues +author: Mario Lang +maintainer: mlang@blind.guru +copyright: 2018 Mario Lang +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + +source-repository head + type: git + location: https://github.com/mlang/brick-dropdownmenu + +flag demo + description: Build the demo program + manual: True + default: False + +library + exposed-modules: + Brick.Widgets.DropDownMenu + other-modules: + Paths_brick_dropdownmenu + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , brick >=0.35 && <0.42 + , containers + , microlens + , microlens-ghc + , microlens-th + , pointedlist + , vector + , vty + default-language: Haskell2010 + +executable brick-dropdownmenu-demo + main-is: Demo.hs + other-modules: + Paths_brick_dropdownmenu + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , brick >=0.35 && <0.42 + , brick-dropdownmenu + , containers + , microlens + , microlens-ghc + , microlens-th + , pointedlist + , text + , vector + , vty + if flag(demo) + buildable: True + else + buildable: False + default-language: Haskell2010 diff --git a/src/Brick/Widgets/DropDownMenu.hs b/src/Brick/Widgets/DropDownMenu.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/DropDownMenu.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-| +Module : Brick.Widgets.DropDownMenu +Description : A drop-down menu type and functions for manipulating and rendering it. +Copyright : (c) Mario Lang, 2018 +License : BSD-style (see the file LICENSE) +Maintainer : mlang@blind.guru +Stability : experimental +Portability : POSIX + +This module provides a simple drop-down menu widget with global key bindings. + +A submenu consists of a title, a resource name, and an associated global event. +Each menu item consists of the items title, resource name, global event and +associated action. + +An action is a function @s -> 'EventM' n ('Next' s)@. +-} +module Brick.Widgets.DropDownMenu ( + DropDownMenu +-- * Constructing a drop-down menu +, dropDownMenu +-- * Handling events +, handleDropDownMenuEvent, handleGlobalDropDownMenuEvent +-- * Rendering drop-down menus +, renderDropDownMenu +-- * Accessors +, isDropDownMenuOpen +-- * Manipulating a drop-down menu +, closeDropDownMenu +-- * Attributes +, menuAttr, menuSelectedAttr +) where + +import Brick ( Named(..) + , AttrName + , EventM, Next + , Location(..), Widget + , continue, emptyWidget + , handleEventLensed + , hBox, hLimit + , padLeftRight, padTopBottom + , showCursor, str + , textWidth, vLimit + , withAttr + ) +import Brick.Widgets.Border ( borderWithLabel ) +import Brick.Widgets.List ( List, list + , handleListEvent + , listElements, listMoveTo + , listSelectedElement + , renderList + ) +import Data.Foldable ( toList ) +import Data.List ( find, findIndex + , intersperse + ) +import Data.List.PointedList ( PointedList + , focus, moveTo, withFocus + ) +import Data.List.PointedList.Circular ( next, previous ) +import qualified Data.List.PointedList as PointedList ( fromList ) +import Data.Map ( Map ) +import qualified Data.Map as Map ( empty, fromList ) +import Data.Maybe ( fromMaybe, mapMaybe ) +import qualified Data.Vector as Vector ( fromList, length ) +import Graphics.Vty ( Event(..) + , Key(..), Modifier(..) + ) +import Lens.Micro.GHC ( Lens', LensLike' + , _2, _Just + , (&), (^.), (^?) + , (.~), (%~), at, set + ) +import Lens.Micro.TH ( makeLenses ) + +type MenuItem s n = (String, n, Maybe Event, s -> EventM n (Next s)) +type Menu s n = [(String, n, Maybe Event, [MenuItem s n])] +data Action s n = MoveTo !Int | Invoke (s -> EventM n (Next s)) + +-- | Drop-down menus present a menu bar with drop-down submenus. +-- +-- Drop-down menus support the following events by default: +-- +-- * Left/right arrow keys: Switch to previous/next submenu +-- * Up arrow key: Close submenu when already at top, otherwise move selection in submenu +-- * Down arrow key: Open submenu or move submenu selection downwards +-- * Escape: Close submenu +-- * Return: Open submenu or invoke selected submenu item +data DropDownMenu s n = DropDownMenu { + _menuName :: n +, _menuOpen :: Bool +, _menuKeyMap :: Map Event (Action s n) +, _menuList :: Maybe (PointedList (String, List n (MenuItem s n))) +} + +makeLenses ''DropDownMenu + +submenuList + :: Applicative f + => LensLike' f (DropDownMenu s n) (List n (MenuItem s n)) +submenuList = menuList . _Just . focus . _2 + +instance Named (DropDownMenu s n) n where getName = _menuName + +dropDownMenu + :: n + -- ^ The resource name for this drop-down menu + -> [(String, n, Maybe Event, [(String, n, Maybe Event, s -> EventM n (Next s))])] + -- ^ Menu description + -> DropDownMenu s n +dropDownMenu name desc = + DropDownMenu name False keyMap $ PointedList.fromList $ + (\(t, n, _, c) -> (t, list n (Vector.fromList c) 1)) <$> desc + where + keyMap = Map.fromList . concat $ zipWith f [0..] desc where + f i (_, _, Just e, xs) = (e, MoveTo i) : mapMaybe g xs + f _ (_, _, Nothing, xs) = mapMaybe g xs + g (_, _, Just e, a) = Just (e, Invoke a) + g (_, _, Nothing, _) = Nothing + + +-- | Handle drop-down menu events. +-- This should typically be called from the application event handler +-- if this menu widget has focus. +handleDropDownMenuEvent + :: (Eq n, Ord n) + => s + -- ^ The application state + -> Lens' s (DropDownMenu s n) + -- ^ A lens for accessing the drop-down menu state + -> (s -> s) + -- ^ Sets focus to this drop-down menu widget if need be + -> Event + -- ^ Event received from Vty + -> EventM n (Next s) +handleDropDownMenuEvent s target setFocus = \case + EvKey KLeft [] -> continue $ s & target.menuList._Just %~ previous + EvKey KRight [] -> continue $ s & target.menuList._Just %~ next + EvKey KEsc [] -> continue $ s & target.menuOpen .~ False + EvKey KUp [] + | s^.target.menuOpen && + fmap fst (listSelectedElement =<< s ^? target.submenuList) == Just 0 -> + continue $ s & target.menuOpen .~ False + EvKey KDown [] + | not $ s^.target.menuOpen -> + continue $ s & target.menuOpen .~ True + & target.submenuList %~ listMoveTo 0 + EvKey KEnter [] + | not $ s^.target.menuOpen -> continue $ s & target.menuOpen .~ True + | otherwise -> + case fmap snd (listSelectedElement =<< s ^? target.submenuList) of + Nothing -> continue s + Just (_, _, _, f) -> f s + e | s^.target.menuOpen -> + fromMaybe (continue =<< handleEventLensed s target handleSubmenuEvent e) $ + handleGlobalDropDownMenuEvent s target setFocus e + | otherwise -> + fromMaybe (continue s) $ + handleGlobalDropDownMenuEvent s target setFocus e + +-- | Handle global events. +-- This function will handle global events associated with submenus +-- or menu items. It should typically be called from the main +-- application event handler before any other more specific handlers. +handleGlobalDropDownMenuEvent + :: (Eq n, Ord n) + => s + -- ^ The application state + -> Lens' s (DropDownMenu s n) + -- ^ A lens for accessing the drop-down menu state + -> (s -> s) + -- ^ Set application focus + -> Event + -- ^ Event received from Vty + -> Maybe (EventM n (Next s)) +handleGlobalDropDownMenuEvent s target setFocus e = go =<< s ^. target . menuKeyMap . at e where + go (MoveTo n) = case moveTo n =<< s ^. target.menuList of + Nothing -> Nothing + l -> pure . continue . setFocus $ + s & target.menuList .~ l + & target.menuOpen .~ True + go (Invoke f) = pure $ f s + +renderDropDownMenu + :: (Eq n, Ord n, Show n) + => Bool + -- ^ Does this menu have focus? + -> DropDownMenu s n + -> Widget n +renderDropDownMenu focused m = case m^?menuList._Just of + Nothing -> emptyWidget + Just menus -> + let o = m^.menuOpen + f ((t, l), sel) = + let cursor = if focused && sel && not o + then showCursor (getName l) (Location (0, 0)) + else id + attr = if focused && sel && not o + then withAttr menuSelectedAttr + else id + height = Vector.length $ listElements l + width = maximum $ textWidth . showMenuItem <$> listElements l + in if focused && sel && o + then borderWithLabel (str t) $ + padLeftRight 1 $ vLimit height $ hLimit width $ + renderList drawMenuItem focused l + else attr $ cursor $ str t + in hBox $ intersperse (str " ") $ map f (toList (withFocus menus)) + +handleSubmenuEvent + :: (Ord n) + => Event + -> DropDownMenu s n + -> EventM n (DropDownMenu s n) +handleSubmenuEvent e m = maybe (pure m) handleEvent $ m ^? menuList._Just where + handleEvent menus = do + menus' <- handleEventLensed menus (focus._2) handleListEvent e + pure $ m & menuList._Just .~ menus' + +drawMenuItem :: Bool -> MenuItem s n -> Widget n +drawMenuItem sel x@(t, n, e, _) = + let cursor = if sel then showCursor n (Location (0, 0)) else id + in cursor $ str $ showMenuItem x + +showMenuItem :: MenuItem s n -> String +showMenuItem (t, _, Just e, _) = t <> " (" <> showEvent e <> ")" +showMenuItem (t, _, Nothing, _) = t + +showEvent :: Event -> String +showEvent (EvKey (KChar c) mods) = concatMap showModifier mods <> [c] where + showModifier MCtrl = "Ctrl-" + showModifier MMeta = "Meta-" + showModifier MAlt = "Alt-" + showModifier _ = "" + +isDropDownMenuOpen :: DropDownMenu s n -> Bool +isDropDownMenuOpen = (^. menuOpen) + +-- | Close submenu. +closeDropDownMenu :: DropDownMenu s n -> DropDownMenu s n +closeDropDownMenu = set menuOpen False + +menuAttr, menuSelectedAttr :: AttrName +menuAttr = "dropdownmenu" +menuSelectedAttr = menuAttr <> "selected"