MenuContainer.hs

module UI.Widgets.MenuContainer where

import qualified Data.Text as T
import System.Console.ANSI (Color(..))
import Text.Printf

import Common
import Highlighter.Highlighter
import UI.Widgets.Common as C

type KeyHandler = forall m. WidgetC m => KeyEvent -> WRef MenuContainerWidget -> m Bool
type SelectionHandler = forall m. WidgetC m => WRef MenuContainerWidget -> (Int, Int) -> m ()

data SubMenu = SubMenu [Text]

data Menu = Menu
  { menuItems  :: [(Text, SubMenu)]
  , menuActive :: Maybe (Int, Int) -- Menu items and sub items are indexed from 0
  , menuTitle :: Maybe Text
  }

data MenuContainerWidget = MenuContainerWidget
  { mcwDim              :: Dimensions
  , mcwContent          :: SomeWidgetRef
  , mcwMenu             :: Menu
  , mcwSelectionHandler :: SelectionHandler
  , mcwVisibility       :: Bool
  }

instance Container MenuContainerWidget SomeWidgetRef where
  setContent ref c =
    modifyWRef ref (\mcw -> mcw { mcwContent = c })
  getContent ref = mcwContent <$> readWRef ref

getSubmenuAt :: Menu -> Int -> Maybe SubMenu
getSubmenuAt (Menu mis _ _) x =
  case safeIndex mis x of
    Just (_, sm) ->  Just sm
    Nothing      -> Nothing

getMenuItem :: Menu -> (Int, Int) -> Maybe [Text]
getMenuItem (Menu mis _ _) (x, y) =
  case safeIndex mis x of
    Just (mmName, SubMenu sm) ->  case safeIndex sm y of
      Just sName -> Just [mmName, sName]
      Nothing    -> Nothing
    Nothing      -> Nothing

instance Widget MenuContainerWidget where
  hasCapability (DrawableCap _)  = Just Dict
  hasCapability _                = Nothing

instance Drawable MenuContainerWidget where
  draw :: forall m. WidgetC m => WRef MenuContainerWidget -> m ()
  setVisibility ref v = modifyWRef ref (\b -> b { mcwVisibility = v })
  getVisibility ref = mcwVisibility <$> readWRef ref
  draw ref = do
    w <- readWRef ref
    drawBorderBox (ScreenPos 0 0) (mcwDim w)
    case mcwMenu w of
      Menu mi _ mtitle -> do
        co <- foldM (\x (n, _) -> do
          csSetCursorPosition x 0
          csPutText (colorText White Black (" "<> n <> " "))
          pure (x + (T.length n + 2))
          ) 2 mi
        case mtitle of
          Just title -> do
            csSetCursorPosition co 0
            csPutText $ colorText White Blue  (" "<> title <> " ")
          Nothing -> pass
    case mcwContent w of
      SomeWidgetRef a -> do
        withCapability (DrawableCap a) $ do
          withCapability (MoveableCap a) $ do
            move a (ScreenPos 1 1)
            resize a (\_ -> amendWidth (\x -> x - 2) $ amendHeight (\x -> x-2) (mcwDim w) )
            draw a
    case menuActive $ mcwMenu w of
      Just (m, s) -> do
        case mcwMenu w of
          Menu mi _ _ -> foldM_ (\(idx, x) (n, submenu) -> do
            if idx == m then do
                case submenu of
                  SubMenu smi -> do
                    let wi = max 30 (Prelude.maximum $ T.length <$> ("": smi))
                    csSetCursorPosition x 0
                    drawBorderBox (ScreenPos x 1) (Dimensions (wi + 2) (Prelude.length smi + 2))
                    foldM_ (\idy n' -> do
                      csSetCursorPosition (x + 1) (idy + 2)
                      let stx = "%-" <> (show wi) <> "s"
                      let cnt = " "<> n'
                      if idy == s
                        then csPutText (colorText White Black (T.pack $ printf stx cnt))
                        else csPutText (colorTextFg White (T.pack $ printf stx cnt))
                      pure (idy+1)) 0 smi
            else pure ()
            pure (idx + 1, x + T.length n + 2)
            ) (0, 2) mi
      Nothing -> pure ()

menuContainer
  :: SomeWidgetRef
  -> Menu
  -> SelectionHandler
  -> WidgetM m (WRef MenuContainerWidget)
menuContainer child menu handler = do
  newWRef $
    MenuContainerWidget
    { mcwDim = Dimensions 0 0
    , mcwContent = child
    , mcwMenu = menu
    , mcwSelectionHandler = handler
    , mcwVisibility = True
    }