Selector.hs

module UI.Widgets.Spade.Selector where

import qualified Data.Text as T
import Data.Typeable
import qualified System.Console.ANSI as A
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Concurrent.STM.TVar

import Common
import DiffRender.DiffRender
import UI.Chars
import UI.Widgets.Common
import Interpreter.Common
import Interpreter.Interpreter

setOptions :: WidgetC m => WRef SelectorWidget -> [(Value, Text)] ->  m ()
setOptions ref options = modifyWRef ref (\s -> s { selHiglighted = Nothing, selSelected = Nothing, selContent = options })

getOptions :: WidgetC m => WRef SelectorWidget -> m [(Value, Text)]
getOptions ref = selContent <$> readWRef ref

getSelection :: WidgetC m => WRef SelectorWidget -> m (Maybe Value)
getSelection ref = do
  w <- readWRef ref
  let a = selSelected w
  let options = selContent w
  case a of
    Just x -> do
      case safeIndex options x of
        Just (y, _) -> do
          pure $ Just y
        Nothing -> error "Invalid selection index"
    Nothing -> pure Nothing

data SelectorWidget = SelectorWidget
  { selContent             :: [(Value, Text)]
  , selLabel               :: Text
  , selSelected            :: Maybe Int
  , selHiglighted          :: Maybe Int
  , selOpen                :: Bool
  , selOptionsBoxLength    :: Int
  , selDim                 :: Dimensions
  , selPos                 :: ScreenPos
  , selVisibility          :: Bool
  , selFocused             :: Bool
  , selOptionsScrollOffset :: Int
  , selAction              :: Maybe Callback
  }


instance Widget SelectorWidget where
  hasCapability (DrawableCap _) = Just Dict
  hasCapability (MoveableCap _) = Just Dict
  hasCapability (FocusableCap _) = Just Dict
  hasCapability (KeyInputCap _) = Just Dict
  hasCapability _ = Nothing

instance Moveable SelectorWidget where
  getPos ref = selPos <$> readWRef ref
  move ref pos =
    modifyWRef ref (\tcw -> tcw { selPos = pos })
  getDim ref = selDim <$> readWRef ref
  resize ref cb =
    modifyWRef ref (\tcw -> tcw { selDim = cb $ selDim tcw })

instance Drawable SelectorWidget where
  setVisibility ref v = modifyWRef ref (\b -> b { selVisibility = v })
  getVisibility ref = selVisibility <$> readWRef ref
  draw ref = do
    w <- readWRef ref
    let
      maxOptionWidth = case selContent w of
        [] -> 0
        x -> Prelude.maximum (T.length . snd <$> x)
    let
      styleFn = if selFocused w
        then (\x -> StyledText (Fg A.Red) [Plain x])
        else Plain
    let
      displayLabel = case selSelected w of
        Just idx -> case safeIndex (selContent w) idx of
          Just t  -> snd t
          Nothing -> selLabel w
        Nothing -> selLabel w
    wSetCursor (selPos w)
    csPutText $ styleFn $ T.singleton verticalLine
    let
      dropBoxWidth = max (diW $ selDim w) maxOptionWidth
      cropWidth t = T.take (dropBoxWidth - 3) t
    wSetCursor (moveRight 1 $ selPos w)
    csPutText (Plain $ (T.singleton downarrow) <> " " <> cropWidth displayLabel)
    if selOpen w
      then do
        let
          printOption (idx, (_, txt)) = do
            wSetCursor (moveRight 1 $ moveDown (idx+1) $ selPos w)
            csPutText $ StyledText (FgBg A.White A.Black) [Plain $ T.replicate dropBoxWidth " "]
            case selHiglighted w of
              Just x -> if x == idx + (selOptionsScrollOffset w)
                then csPutText (StyledText (FgBg A.Red A.Black) [Plain $ "  " <> cropWidth txt])
                else csPutText (StyledText (FgBg A.White A.Black) [Plain $ "  " <> cropWidth txt])
              Nothing -> csPutText (StyledText (FgBg A.White A.Black) [Plain $ "  " <> cropWidth txt])
        let itemsLength = Prelude.length (selContent w)
        let itemsBoxLength = min itemsLength (selOptionsBoxLength w)
        let maxScrollOffset = max 0 (itemsLength - itemsBoxLength)
        let maxScrollbarPos = itemsBoxLength - 1
        let mScrollbarPos = if maxScrollOffset > 0 then Just $ max 0 $ min maxScrollbarPos (div (maxScrollbarPos * (div (selOptionsScrollOffset w * 100) maxScrollOffset)) 100) else Nothing
        mapM_ printOption $ Prelude.zip [0..] (Prelude.take itemsBoxLength $ Prelude.drop (selOptionsScrollOffset w) $ selContent w)
        case mScrollbarPos of
          Just scrollbarPos -> do
            wSetCursor $ moveDown (scrollbarPos + 1) (moveRight (diW $ selDim w) $ selPos w)
            csPutText $ Plain (T.singleton block)
          Nothing -> pass
      else pass

instance KeyInput SelectorWidget where
  handleInput :: forall m. WidgetC m => WRef SelectorWidget -> KeyEvent -> m ()
  handleInput ref ev = do
    case ev of
      KeyCtrl _ _ _ ArrowUp -> do
        w <- readWRef ref
        case selOpen w of
          True  -> modifyWRef ref (moveSelection -1)
          False -> modifyWRef ref (\u -> u { selOpen = True })
      KeyCtrl _ _ _ ArrowDown -> do
        w <- readWRef ref
        case selOpen w of
          True  -> modifyWRef ref (moveSelection 1)
          False -> modifyWRef ref (\u -> u { selOpen = True })
      KeyCtrl _ _ _ Return -> do
        w <- readWRef ref
        case selOpen w of
          True  -> do
            modifyWRef ref (\u -> u { selSelected = selHiglighted w, selOpen = False })
            case selHiglighted w of
              Just _ -> do
                case (selAction w) of
                  Just cb -> case eqT @m @(ReaderT (TVar InterpreterState) IO) of
                    Just Refl -> void $ evaluateCallback cb [WidgetValue (SomeWidgetRef ref)]
                    Nothing -> error ""
                  Nothing -> pass
              Nothing -> pass
          False -> pass
      _ -> pass
  getCursorInfo _ = pure Nothing

moveSelection :: Int -> SelectorWidget -> SelectorWidget
moveSelection d w = let
  newHiglighted = case selHiglighted w of
    Just idx -> idx + d
    Nothing  -> 0
  newHiglighted' = max 0 (min newHiglighted ((Prelude.length (selContent w)) - 1))
  newScrollOffset = max 0 (newHiglighted' - 4)
  in w { selOptionsScrollOffset = newScrollOffset, selHiglighted = Just newHiglighted' }

instance Focusable SelectorWidget where
  setFocus ref b =
    modifyWRef ref (\w -> w { selFocused = b })
  getFocus ref =
    selFocused <$> (readWRef ref)

selector
  :: WidgetC m
  => Text
  -> ScreenPos
  -> Dimensions
  -> [(Value, Text)]
  -> Maybe Callback
  -> m (WRef SelectorWidget)
selector label sp dim options action = newWRef $ SelectorWidget options label Nothing Nothing False 5 dim sp True False 0 action