Layout.hs

module UI.Widgets.Spade.Layout where

import Data.Maybe
import Data.List (sortBy)

import Common
import UI.Widgets.Common

data Orientation
  = Vertical
  | Horizontal
  deriving Show

newtype ContentId = ContentId Text
  deriving (Show, Ord, Eq)

data LayoutWidget = LayoutWidget
  { lowDim              :: Dimensions
  , lowPos              :: ScreenPos
  , lowContent          :: [StackedWidget]
  , lowOrientation      :: Orientation
  , lowVisibility       :: Bool
  , lowFloatingContent  :: [SomeWidgetRef]
  , lowDimensionDistribution :: [[Double]]
  , lowFocusWidget      :: Maybe (Int, SomeWidgetRef)
  , lowFocused          :: Bool
  , lowResizeChildren   :: Bool
  }

instance Focusable LayoutWidget where
  getFocus ref = lowFocused <$> readWRef ref
  setFocus ref b = do
    modifyWRef ref (\w' -> w' { lowFocused = b })
    w <- readWRef ref
    case lowFocusWidget w of
      Just (_, SomeWidgetRef elm) -> do
        withCapability (FocusableCap elm) $ setFocus elm b
      Nothing -> void $ setFocusAt ref 0 1 True

instance KeyInput LayoutWidget where
  getCursorInfo _ = pure Nothing
  handleInput ref keyEvent = do
    case keyEvent of
      KeyCtrl _ False _ Tab -> void $ focusNext ref 1
      KeyCtrl _ True _ Tab -> void $ focusNext ref (-1)
      _ -> do
        w <- readWRef ref
        case lowFocusWidget w of
          Just (_, (SomeWidgetRef r)) -> case hasCapability (KeyInputCap r) of
            Just Dict -> handleInput r keyEvent
            Nothing -> pass
          Nothing -> pass

computeDim :: forall m. WidgetC m => Dimensions -> Orientation -> Bool -> [StackedWidget] -> m Dimensions
computeDim dim _ True _ = pure dim
computeDim _ _ False [] = pure $ Dimensions 0 0
computeDim _ ori False children = do
  dimensions <- mapM getChildDimension children
  let heights = diH <$> dimensions
  let widths = diW <$> dimensions
  case ori of
    Vertical -> pure $ Dimensions (Prelude.maximum widths) (sum heights)
    Horizontal -> do
      pure $ Dimensions (sum widths) (Prelude.maximum heights)
  where
    getChildDimension :: StackedWidget -> m Dimensions
    getChildDimension (StackedWidget _ (SomeWidgetRef ref)) = withCapability (MoveableCap ref) $ getDim ref

instance Layout LayoutWidget where
  addWidget' ref so child =
    modifyWRefM ref (\low -> do
      let newContent = (lowContent low) ++ [(StackedWidget so (SomeWidgetRef child))]
      pure low { lowContent =  newContent })
  focusNext ref d = do
    w <- readWRef ref
    case lowFocusWidget w of
      Just (cidx, (SomeWidgetRef cref)) -> do
        case hasCapability (LayoutCap cref) of
          Nothing -> do
            setFocusAt ref (cidx + d) d True >>= \case
              True -> setFocusAt ref cidx d False
              _ -> pure False
          Just Dict -> do
            focusNext cref d >>= \case
              True -> pure True
              False -> do
                setFocusAt ref (cidx + d) d True >>= \case
                  True -> setFocusAt ref cidx d False
                  _ -> pure False

      Nothing -> pure False

setFocusAt :: WidgetC m => WRef LayoutWidget -> Int -> Int -> Bool -> m Bool
setFocusAt ref idx dir b = do
  w <- readWRef ref
  let cSize = Prelude.length (lowContent w)
  if idx >= 0 && idx < cSize
    then do
      case (lowContent w) !! idx of
        (StackedWidget _ (SomeWidgetRef c)) -> do
          r <- case hasCapability (FocusableCap c) of
            Just Dict -> do
              setFocus c b
              if b then modifyWRef ref (\w' -> w' { lowFocusWidget = Just (idx, SomeWidgetRef c) }) else pass
              case hasCapability (KeyInputCap c) of
                Just Dict -> do
                  modifyWidgetState (\ws -> ws { wsCursorVisible = True, wsCursorWidget = Just (SomeKeyInputWidget c) })
                _ -> pass
              pure True
            Nothing -> do
              setFocusAt ref (idx + dir) dir b
          pure r
    else pure False

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

instance Moveable LayoutWidget where
  getPos ref = lowPos <$> readWRef ref
  move ref pos =
    modifyWRef ref (\low -> low { lowPos = pos })
  getDim ref = do
    low <- readWRef ref
    computeDim (lowDim low) (lowOrientation low) (lowResizeChildren low) (lowContent low)
  resize ref cb =
    modifyWRef ref (\low -> low { lowDim = cb $ lowDim low })

instance Drawable LayoutWidget where
  setVisibility ref v = modifyWRef ref (\b -> b { lowVisibility = v })
  getVisibility ref = lowVisibility <$> readWRef ref
  draw ref = do
    w <- readWRef ref
    let
      dimension = case lowOrientation w of
        Vertical   -> (diH $ lowDim w)
        Horizontal -> (diW $ lowDim w)
    visibileItems <- catMaybes <$> mapM (\sw@(StackedWidget _ (SomeWidgetRef cw)) -> case hasCapability (DrawableCap cw) of
      Just Dict -> do
        b <- getVisibility cw
        case b of
          True -> pure $ Just sw
          _    -> pure Nothing
      Nothing -> pure Nothing) (lowContent w)

    let
      itemCount = Prelude.length visibileItems
      dimensionDistribution = (lowDimensionDistribution w) !! itemCount
      resizeCallback d = case lowOrientation w of
        Vertical -> (\dm -> dm { diW = diW $ lowDim w , diH = d})
        Horizontal -> (\dm -> dm { diH = diH $ lowDim w, diW = d })

    if (lowResizeChildren w)
      then do
        foldM_ (\totalDim (idx, (fraction, StackedWidget _ (SomeWidgetRef cw))) ->
          withCapability (MoveableCap cw) $ do
            let thisDim' =
                  if (idx == itemCount) then (dimension - totalDim) else round $ (realToFrac dimension) * fraction
            let thisDim =  max thisDim' 3
            resize cw (resizeCallback thisDim)
            pure (totalDim + thisDim)
            ) 0 (Prelude.zip [1..] (Prelude.zip dimensionDistribution visibileItems))
      else do
        let
          resizeCallback' = case lowOrientation w of
            Vertical -> (\dm -> dm { diW = diW $ lowDim w })
            Horizontal -> (\dm -> dm { diH = diH $ lowDim w })
        mapM_ (\(StackedWidget _ (SomeWidgetRef cw)) -> withCapability (MoveableCap cw) $ resize cw resizeCallback') (lowContent w)

    case (lowOrientation w) of
      Vertical   -> foldM_ (fny (sX $ lowPos w)) (sY $ lowPos w) $ swSw <$> visibileItems
      Horizontal -> foldM_ (fn (sY $ lowPos w)) (sX $ lowPos w) $ swSw <$> visibileItems
    mapM_ (\(SomeWidgetRef a) -> withCapability (DrawableCap a) $ draw a) $ sortBySo visibileItems
    flip mapM_ (lowFloatingContent w) $ \(SomeWidgetRef f) -> do
      withCapability (DrawableCap f) $ draw f
    where
      sortBySo :: [StackedWidget] -> [SomeWidgetRef]
      sortBySo ws = swSw <$> (sortBy (\a b -> compare (swSo a) (swSo b)) ws)

      fny x y w = case w of
        SomeWidgetRef a ->
          withCapability (MoveableCap a) $ do
            dim <- getDim a
            move a (ScreenPos { sY = y, sX = x })
            pure (y + (diH dim))
      fn y x w = case w of
        SomeWidgetRef a ->
          withCapability (MoveableCap a) $ do
            dim <- getDim a
            move a (ScreenPos { sY = y, sX = x })
            pure (x + (diW dim))

layoutWidget
  :: WidgetC m
  => Orientation
  -> [[Double]]
  -> [SomeWidgetRef]
  -> m (WRef LayoutWidget)
layoutWidget ori distr children = do
  newWRef $
    LayoutWidget
    { lowDim = Dimensions 600 1
    , lowPos = origin
    , lowContent = (\c -> StackedWidget 0 c) <$> children
    , lowOrientation = ori
    , lowVisibility = True
    , lowFloatingContent = []
    , lowDimensionDistribution = distr
    , lowFocusWidget = Nothing
    , lowFocused = False
    , lowResizeChildren = True
    }

simpleLayoutWidget
  :: WidgetC m
  => Orientation
  -> [SomeWidgetRef]
  -> m (WRef LayoutWidget)
simpleLayoutWidget ori children = do
  newWRef $
    LayoutWidget
    { lowDim = Dimensions 1 1
    , lowPos = origin
    , lowContent = (\c -> StackedWidget 0 c) <$> children
    , lowOrientation = ori
    , lowVisibility = True
    , lowFloatingContent = []
    , lowDimensionDistribution = []
    , lowFocusWidget = Nothing
    , lowFocused = False
    , lowResizeChildren = False
    }