{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module provides the core widget combinators and rendering
-- routines. Everything this library does is in terms of these basic
-- primitives.
module Brick.Widgets.Core
  ( -- * Basic rendering primitives
    TextWidth(..)
  , emptyWidget
  , raw
  , txt
  , txtWrap
  , txtWrapWith
  , str
  , strWrap
  , strWrapWith
  , fill
  , hyperlink

  -- * Padding
  , padLeft
  , padRight
  , padTop
  , padBottom
  , padLeftRight
  , padTopBottom
  , padAll

  -- * Box layout
  , (<=>)
  , (<+>)
  , hBox
  , vBox

  -- * Limits
  , hLimit
  , hLimitPercent
  , vLimit
  , vLimitPercent
  , setAvailableSize

  -- * Attribute management
  , withDefAttr
  , modifyDefAttr
  , withAttr
  , forceAttr
  , overrideAttr
  , updateAttrMap

  -- * Border style management
  , withBorderStyle
  , joinBorders
  , separateBorders
  , freezeBorders

  -- * Cursor placement
  , showCursor

  -- * Naming
  , Named(..)

  -- * Translation
  , translateBy

  -- * Cropping
  , cropLeftBy
  , cropRightBy
  , cropTopBy
  , cropBottomBy

  -- * Extent reporting
  , reportExtent
  , clickable

  -- * Scrollable viewports
  , viewport
  , visible
  , visibleRegion
  , unsafeLookupViewport
  , cached

  -- ** Adding offsets to cursor positions and visibility requests
  , addResultOffset

  -- ** Cropping results
  , cropToContext
  )
where

#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid ((<>), mempty)
#endif

import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens')
import Lens.Micro.Mtl (use, (%=))
import Control.Monad ((>=>),when)
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class (lift)
import qualified Data.Foldable as F
import qualified Data.Text as T
import qualified Data.DList as DL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IMap as I
import qualified Data.Function as DF
import Data.List (sortBy, partition)
import qualified Graphics.Vty as V
import Control.DeepSeq

import Text.Wrap (wrapTextToLines, WrapSettings, defaultWrapSettings)

import Brick.Types
import Brick.Types.Internal
import Brick.Widgets.Border.Style
import Brick.Util (clOffset, clamp)
import Brick.AttrMap
import Brick.Widgets.Internal
import qualified Brick.BorderMap as BM

-- | The class of text types that have widths measured in terminal
-- columns. NEVER use 'length' etc. to measure the length of a string if
-- you need to compute how much screen space it will occupy; always use
-- 'textWidth'.
class TextWidth a where
    textWidth :: a -> Int

instance TextWidth T.Text where
    textWidth = V.wcswidth . T.unpack

instance (F.Foldable f) => TextWidth (f Char) where
    textWidth = V.wcswidth . F.toList

-- | The class of types that store interface element names.
class Named a n where
    -- | Get the name of the specified value.
    getName :: a -> n

-- | When rendering the specified widget, use the specified border style
-- for any border rendering.
withBorderStyle :: BorderStyle -> Widget n -> Widget n
withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p)

-- | When rendering the specified widget, create borders that respond
-- dynamically to their neighbors to form seamless connections.
joinBorders :: Widget n -> Widget n
joinBorders p = Widget (hSize p) (vSize p) $ withReaderT (& ctxDynBordersL .~ True) (render p)

-- | When rendering the specified widget, use static borders. This
-- may be marginally faster, but will introduce a small gap between
-- neighboring orthogonal borders.
--
-- This is the default for backwards compatibility.
separateBorders :: Widget n -> Widget n
separateBorders p = Widget (hSize p) (vSize p) $ withReaderT (&ctxDynBordersL .~ False) (render p)

-- | After the specified widget has been rendered, freeze its borders. A
-- frozen border will not be affected by neighbors, nor will it affect
-- neighbors. Compared to 'separateBorders', 'freezeBorders' will not
-- affect whether borders connect internally to a widget (whereas
-- 'separateBorders' prevents them from connecting).
--
-- Frozen borders cannot be thawed.
freezeBorders :: Widget n -> Widget n
freezeBorders p = Widget (hSize p) (vSize p) $ (bordersL .~ BM.empty) <$> render p

-- | The empty widget.
emptyWidget :: Widget n
emptyWidget = raw V.emptyImage

-- | Add an offset to all cursor locations, visbility requests, and
-- extents in the specified rendering result. This function is critical
-- for maintaining correctness in the rendering results as they are
-- processed successively by box layouts and other wrapping combinators,
-- since calls to this function result in converting from widget-local
-- coordinates to (ultimately) terminal-global ones so they can be
-- used by other combinators. You should call this any time you render
-- something and then translate it or otherwise offset it from its
-- original origin.
addResultOffset :: Location -> Result n -> Result n
addResultOffset off = addCursorOffset off .
                      addVisibilityOffset off .
                      addExtentOffset off .
                      addDynBorderOffset off

addVisibilityOffset :: Location -> Result n -> Result n
addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>)

addExtentOffset :: Location -> Result n -> Result n
addExtentOffset off r = r & extentsL.each %~ (\(Extent n l sz o) -> Extent n (off <> l) sz o)

addDynBorderOffset :: Location -> Result n -> Result n
addDynBorderOffset off r = r & bordersL %~ BM.translate off

-- | Render the specified widget and record its rendering extent using
-- the specified name (see also 'lookupExtent').
reportExtent :: n -> Widget n -> Widget n
reportExtent n p =
    Widget (hSize p) (vSize p) $ do
        result <- render p
        let ext = Extent n (Location (0, 0)) sz (Location (0, 0))
            sz = ( result^.imageL.to V.imageWidth
                 , result^.imageL.to V.imageHeight
                 )
        return $ result & extentsL %~ (ext:)

-- | Request mouse click events on the specified widget.
clickable :: n -> Widget n -> Widget n
clickable n p =
    Widget (hSize p) (vSize p) $ do
        clickableNamesL %= (n:)
        render $ reportExtent n p

addCursorOffset :: Location -> Result n -> Result n
addCursorOffset off r =
    let onlyVisible = filter isVisible
        isVisible l = l^.locationColumnL >= 0 && l^.locationRowL >= 0
    in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs)

unrestricted :: Int
unrestricted = 100000

-- | Take a substring capable of fitting into the number of specified
-- columns. This function takes character column widths into
-- consideration.
takeColumns :: Int -> String -> String
takeColumns _ "" = ""
takeColumns numCols (c:cs) =
    let w = V.safeWcwidth c
    in if w > numCols
       then []
       else c : takeColumns (numCols - w) cs

-- | Make a widget from a string, but wrap the words in the input's
-- lines at the available width using the default wrapping settings. The
-- input string should not contain escape sequences or carriage returns.
--
-- Unlike 'str', this is greedy horizontally.
strWrap :: String -> Widget n
strWrap = strWrapWith defaultWrapSettings

-- | Make a widget from a string, but wrap the words in the input's
-- lines at the available width using the specified wrapping settings.
-- The input string should not contain escape sequences or carriage
-- returns.
--
-- Unlike 'str', this is greedy horizontally.
strWrapWith :: WrapSettings -> String -> Widget n
strWrapWith settings t = txtWrapWith settings $ T.pack t

safeTextWidth :: T.Text -> Int
safeTextWidth = V.safeWcswidth . T.unpack

-- | Make a widget from text, but wrap the words in the input's lines at
-- the available width using the default wrapping settings. The input
-- text should not contain escape sequences or carriage returns.
--
-- Unlike 'txt', this is greedy horizontally.
txtWrap :: T.Text -> Widget n
txtWrap = txtWrapWith defaultWrapSettings

-- | Make a widget from text, but wrap the words in the input's lines at
-- the available width using the specified wrapping settings. The input
-- text should not contain escape sequences or carriage returns.
--
-- Unlike 'txt', this is greedy horizontally.
txtWrapWith :: WrapSettings -> T.Text -> Widget n
txtWrapWith settings s =
    Widget Greedy Fixed $ do
      c <- getContext
      let theLines = fixEmpty <$> wrapTextToLines settings (c^.availWidthL) s
          fixEmpty l | T.null l = " "
                     | otherwise = l
      case force theLines of
          [] -> return emptyResult
          multiple ->
              let maxLength = maximum $ safeTextWidth <$> multiple
                  padding = V.charFill (c^.attrL) ' ' (c^.availWidthL - maxLength) (length lineImgs)
                  lineImgs = lineImg <$> multiple
                  lineImg lStr = V.text' (c^.attrL)
                                   (lStr <> T.replicate (maxLength - safeTextWidth lStr) " ")
              in return $ emptyResult & imageL .~ (V.horizCat [V.vertCat lineImgs, padding])

-- | Build a widget from a 'String'. Breaks newlines up and space-pads
-- short lines out to the length of the longest line.
--
-- The input string must not contain tab characters. If it does,
-- interface corruption will result since the terminal will likely
-- render it as taking up more than a single column. The caller should
-- replace tabs with the appropriate number of spaces as desired. The
-- input string should not contain escape sequences or carriage returns.
str :: String -> Widget n
str s =
    Widget Fixed Fixed $ do
      c <- getContext
      let theLines = fixEmpty <$> (dropUnused . lines) s
          fixEmpty :: String -> String
          fixEmpty [] = " "
          fixEmpty l = l
          dropUnused l = takeColumns (availWidth c) <$> take (availHeight c) l
      case force theLines of
          [] -> return emptyResult
          [one] -> return $ emptyResult & imageL .~ (V.string (c^.attrL) one)
          multiple ->
              let maxLength = maximum $ V.safeWcswidth <$> multiple
                  lineImgs = lineImg <$> multiple
                  lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - V.safeWcswidth lStr) ' ')
              in return $ emptyResult & imageL .~ (V.vertCat lineImgs)

-- | Build a widget from a 'T.Text' value. Behaves the same as 'str'
-- when the input contains multiple lines.
--
-- The input string must not contain tab characters. If it does,
-- interface corruption will result since the terminal will likely
-- render it as taking up more than a single column. The caller should
-- replace tabs with the appropriate number of spaces as desired. The
-- input text should not contain escape sequences or carriage returns.
txt :: T.Text -> Widget n
txt = str . T.unpack

-- | Hyperlink the given widget to the specified URL. Not all terminal
-- emulators support this. In those that don't, this should have no
-- discernible effect.
hyperlink :: T.Text -> Widget n -> Widget n
hyperlink url p =
    Widget (hSize p) (vSize p) $ do
        c <- getContext
        let attr = attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL) `V.withURL` url
        withReaderT (& ctxAttrMapL %~ setDefaultAttr attr) (render p)

-- | Pad the specified widget on the left. If max padding is used, this
-- grows greedily horizontally; otherwise it defers to the padded
-- widget.
padLeft :: Padding -> Widget n -> Widget n
padLeft padding p =
    let (f, sz) = case padding of
          Max -> (id, Greedy)
          Pad i -> (hLimit i, hSize p)
    in Widget sz (vSize p) $ do
        c <- getContext
        let lim = case padding of
              Max -> c^.availWidthL
              Pad i -> c^.availWidthL - i
        result <- render $ hLimit lim p
        render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+>
                 (Widget Fixed Fixed $ return result)

-- | Pad the specified widget on the right. If max padding is used,
-- this grows greedily horizontally; otherwise it defers to the padded
-- widget.
padRight :: Padding -> Widget n -> Widget n
padRight padding p =
    let (f, sz) = case padding of
          Max -> (id, Greedy)
          Pad i -> (hLimit i, hSize p)
    in Widget sz (vSize p) $ do
        c <- getContext
        let lim = case padding of
              Max -> c^.availWidthL
              Pad i -> c^.availWidthL - i
        result <- render $ hLimit lim p
        render $ (Widget Fixed Fixed $ return result) <+>
                 (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ')

-- | Pad the specified widget on the top. If max padding is used, this
-- grows greedily vertically; otherwise it defers to the padded widget.
padTop :: Padding -> Widget n -> Widget n
padTop padding p =
    let (f, sz) = case padding of
          Max -> (id, Greedy)
          Pad i -> (vLimit i, vSize p)
    in Widget (hSize p) sz $ do
        c <- getContext
        let lim = case padding of
              Max -> c^.availHeightL
              Pad i -> c^.availHeightL - i
        result <- render $ vLimit lim p
        render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=>
                 (Widget Fixed Fixed $ return result)

-- | Pad the specified widget on the bottom. If max padding is used,
-- this grows greedily vertically; otherwise it defers to the padded
-- widget.
padBottom :: Padding -> Widget n -> Widget n
padBottom padding p =
    let (f, sz) = case padding of
          Max -> (id, Greedy)
          Pad i -> (vLimit i, vSize p)
    in Widget (hSize p) sz $ do
        c <- getContext
        let lim = case padding of
              Max -> c^.availHeightL
              Pad i -> c^.availHeightL - i
        result <- render $ vLimit lim p
        render $ (Widget Fixed Fixed $ return result) <=>
                 (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ')

-- | Pad a widget on the left and right. Defers to the padded widget for
-- growth policy.
padLeftRight :: Int -> Widget n -> Widget n
padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w

-- | Pad a widget on the top and bottom. Defers to the padded widget for
-- growth policy.
padTopBottom :: Int -> Widget n -> Widget n
padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w

-- | Pad a widget on all sides. Defers to the padded widget for growth
-- policy.
padAll :: Int -> Widget n -> Widget n
padAll v w = padLeftRight v $ padTopBottom v w

-- | Fill all available space with the specified character. Grows both
-- horizontally and vertically.
fill :: Char -> Widget n
fill ch =
    Widget Greedy Greedy $ do
      c <- getContext
      return $ emptyResult & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL))

-- | Vertical box layout: put the specified widgets one above the other
-- in the specified order (uppermost first). Defers growth policies to
-- the growth policies of the contained widgets (if any are greedy, so
-- is the box).
{-# NOINLINE vBox #-}
vBox :: [Widget n] -> Widget n
vBox [] = emptyWidget
vBox [a] = a
vBox pairs = renderBox vBoxRenderer pairs

-- | Horizontal box layout: put the specified widgets next to each other
-- in the specified order (leftmost first). Defers growth policies to
-- the growth policies of the contained widgets (if any are greedy, so
-- is the box).
{-# NOINLINE hBox #-}
hBox :: [Widget n] -> Widget n
hBox [] = emptyWidget
hBox [a] = a
hBox pairs = renderBox hBoxRenderer pairs

-- | The process of rendering widgets in a box layout is exactly the
-- same except for the dimension under consideration (width vs. height),
-- in which case all of the same operations that consider one dimension
-- in the layout algorithm need to be switched to consider the other.
-- Because of this we fill a BoxRenderer with all of the functions
-- needed to consider the "primary" dimension (e.g. vertical if the
-- box layout is vertical) as well as the "secondary" dimension (e.g.
-- horizontal if the box layout is vertical). Doing this permits us to
-- have one implementation for box layout and parameterizing on the
-- orientation of all of the operations.
data BoxRenderer n =
    BoxRenderer { contextPrimary :: Lens' Context Int
                , contextSecondary :: Lens' Context Int
                , imagePrimary :: V.Image -> Int
                , imageSecondary :: V.Image -> Int
                , limitPrimary :: Int -> Widget n -> Widget n
                , limitSecondary :: Int -> Widget n -> Widget n
                , primaryWidgetSize :: Widget n -> Size
                , concatenatePrimary :: [V.Image] -> V.Image
                , concatenateSecondary :: [V.Image] -> V.Image
                , locationFromOffset :: Int -> Location
                , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image
                , loPrimary :: forall a. Lens' (Edges a) a -- lo: towards smaller coordinates in that dimension
                , hiPrimary :: forall a. Lens' (Edges a) a -- hi: towards larger  coordinates in that dimension
                , loSecondary :: forall a. Lens' (Edges a) a
                , hiSecondary :: forall a. Lens' (Edges a) a
                , locationFromPrimarySecondary :: Int -> Int -> Location
                , splitLoPrimary :: Int -> V.Image -> V.Image
                , splitHiPrimary :: Int -> V.Image -> V.Image
                , splitLoSecondary :: Int -> V.Image -> V.Image
                , splitHiSecondary :: Int -> V.Image -> V.Image
                , lookupPrimary :: Int -> BM.BorderMap DynBorder -> I.IMap DynBorder
                , insertSecondary :: Location -> I.Run DynBorder -> BM.BorderMap DynBorder -> BM.BorderMap DynBorder
                }

vBoxRenderer :: BoxRenderer n
vBoxRenderer =
    BoxRenderer { contextPrimary = availHeightL
                , contextSecondary = availWidthL
                , imagePrimary = V.imageHeight
                , imageSecondary = V.imageWidth
                , limitPrimary = vLimit
                , limitSecondary = hLimit
                , primaryWidgetSize = vSize
                , concatenatePrimary = V.vertCat
                , concatenateSecondary = V.horizCat
                , locationFromOffset = Location . (0 ,)
                , padImageSecondary = \amt img a ->
                    let p = V.charFill a ' ' amt (V.imageHeight img)
                    in V.horizCat [img, p]
                , loPrimary = eTopL
                , hiPrimary = eBottomL
                , loSecondary = eLeftL
                , hiSecondary = eRightL
                , locationFromPrimarySecondary = \r c -> Location (c, r)
                , splitLoPrimary = V.cropBottom
                , splitHiPrimary = \n img -> V.cropTop (V.imageHeight img-n) img
                , splitLoSecondary = V.cropRight
                , splitHiSecondary = \n img -> V.cropLeft (V.imageWidth img-n) img
                , lookupPrimary = BM.lookupRow
                , insertSecondary = BM.insertH
                }

hBoxRenderer :: BoxRenderer n
hBoxRenderer =
    BoxRenderer { contextPrimary = availWidthL
                , contextSecondary = availHeightL
                , imagePrimary = V.imageWidth
                , imageSecondary = V.imageHeight
                , limitPrimary = hLimit
                , limitSecondary = vLimit
                , primaryWidgetSize = hSize
                , concatenatePrimary = V.horizCat
                , concatenateSecondary = V.vertCat
                , locationFromOffset = Location . (, 0)
                , padImageSecondary = \amt img a ->
                    let p = V.charFill a ' ' (V.imageWidth img) amt
                    in V.vertCat [img, p]
                , loPrimary = eLeftL
                , hiPrimary = eRightL
                , loSecondary = eTopL
                , hiSecondary = eBottomL
                , locationFromPrimarySecondary = \c r -> Location (c, r)
                , splitLoPrimary = V.cropRight
                , splitHiPrimary = \n img -> V.cropLeft (V.imageWidth img-n) img
                , splitLoSecondary = V.cropBottom
                , splitHiSecondary = \n img -> V.cropTop (V.imageHeight img-n) img
                , lookupPrimary = BM.lookupCol
                , insertSecondary = BM.insertV
                }

-- | Render a series of widgets in a box layout in the order given.
--
-- The growth policy of a box layout is the most unrestricted of the
-- growth policies of the widgets it contains, so to determine the hSize
-- and vSize of the box we just take the maximum (using the Ord instance
-- for Size) of all of the widgets to be rendered in the box.
--
-- Then the box layout algorithm proceeds as follows. We'll use
-- the vertical case to concretely describe the algorithm, but the
-- horizontal case can be envisioned just by exchanging all
-- "vertical"/"horizontal" and "rows"/"columns", etc., in the
-- description.
--
-- The growth policies of the child widgets determine the order in which
-- they are rendered, i.e., the order in which space in the box is
-- allocated to widgets as the algorithm proceeds. This is because order
-- matters: if we render greedy widgets first, there will be no space
-- left for non-greedy ones.
--
-- So we render all widgets with size 'Fixed' in the vertical dimension
-- first. Each is rendered with as much room as the overall box has, but
-- we assume that they will not be greedy and use it all. If they do,
-- maybe it's because the terminal is small and there just isn't enough
-- room to render everything.
--
-- Then the remaining height is distributed evenly amongst all remaining
-- (greedy) widgets and they are rendered in sub-boxes that are as high
-- as this even slice of rows and as wide as the box is permitted to be.
-- We only do this step at all if rendering the non-greedy widgets left
-- us any space, i.e., if there were any rows left.
--
-- After rendering the non-greedy and then greedy widgets, their images
-- are sorted so that they are stored in the order the original widgets
-- were given. All cursor locations and visibility requests in each
-- sub-widget are translated according to the position of the sub-widget
-- in the box.
--
-- All images are padded to be as wide as the widest sub-widget to
-- prevent attribute over-runs. Without this step the attribute used by
-- a sub-widget may continue on in an undesirable fashion until it hits
-- something with a different attribute. To prevent this and to behave
-- in the least surprising way, we pad the image on the right with
-- whitespace using the context's current attribute.
--
-- Finally, the padded images are concatenated together vertically and
-- returned along with the translated cursor positions and visibility
-- requests.
renderBox :: BoxRenderer n -> [Widget n] -> Widget n
renderBox br ws =
    Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do
      c <- getContext

      let pairsIndexed = zip [(0::Int)..] ws
          (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed)
                        pairsIndexed

      let availPrimary = c^.(contextPrimary br)
          availSecondary = c^.(contextSecondary br)

          renderHis _ prev [] = return $ DL.toList prev
          renderHis remainingPrimary prev ((i, prim):rest) = do
              result <- render $ limitPrimary br remainingPrimary
                               $ limitSecondary br availSecondary
                               $ cropToContext prim
              renderHis (remainingPrimary - (result^.imageL.(to $ imagePrimary br)))
                        (DL.snoc prev (i, result)) rest

      renderedHis <- renderHis availPrimary DL.empty his

      renderedLows <- case lows of
          [] -> return []
          ls -> do
              let remainingPrimary = c^.(contextPrimary br) -
                                     (sum $ (^._2.imageL.(to $ imagePrimary br)) <$> renderedHis)
                  primaryPerLow = remainingPrimary `div` length ls
                  rest = remainingPrimary - (primaryPerLow * length ls)
                  secondaryPerLow = c^.(contextSecondary br)
                  primaries = replicate rest (primaryPerLow + 1) <>
                              replicate (length ls - rest) primaryPerLow

              let renderLow ((i, prim), pri) =
                      (i,) <$> (render $ limitPrimary br pri
                                       $ limitSecondary br secondaryPerLow
                                       $ cropToContext prim)

              if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return []

      let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows
          allResults = snd <$> rendered
          allImages = (^.imageL) <$> allResults
          allPrimaries = imagePrimary br <$> allImages
          allTranslatedResults = (flip map) (zip [0..] allResults) $ \(i, result) ->
              let off = locationFromOffset br offPrimary
                  offPrimary = sum $ take i allPrimaries
              in addResultOffset off result
          -- Determine the secondary dimension value to pad to. In a
          -- vertical box we want all images to be the same width to
          -- avoid attribute over-runs or blank spaces with the wrong
          -- attribute. In a horizontal box we want all images to have
          -- the same height for the same reason.
          maxSecondary = maximum $ imageSecondary br <$> allImages
          padImage img = padImageSecondary br (maxSecondary - imageSecondary br img)
                         img (c^.attrL)
          (imageRewrites, newBorders) = catAllBorders br (borders <$> allTranslatedResults)
          rewrittenImages = zipWith (rewriteImage br) imageRewrites allImages
          paddedImages = padImage <$> rewrittenImages

      cropResultToContext $ Result (concatenatePrimary br paddedImages)
                            (concat $ cursors <$> allTranslatedResults)
                            (concat $ visibilityRequests <$> allTranslatedResults)
                            (concat $ extents <$> allTranslatedResults)
                            newBorders

catDynBorder
    :: Lens' (Edges BorderSegment) BorderSegment
    -> Lens' (Edges BorderSegment) BorderSegment
    -> DynBorder
    -> DynBorder
    -> Maybe DynBorder
catDynBorder towardsA towardsB a b
    -- Currently, we check if the 'BorderStyle's are exactly the same. In the
    -- future, it might be nice to relax this restriction. For example, if a
    -- horizontal border is being rewritten to accommodate a neighboring
    -- vertical border, all we care about is that the two 'bsVertical's line up
    -- sanely. After all, if the horizontal border's 'bsVertical' is the same
    -- as the vertical one's, and the horizontal border's 'BorderStyle' is
    -- self-consistent, then it will look "right" to rewrite according to the
    -- horizontal border's 'BorderStyle'.
    |  dbStyle a == dbStyle b
    && dbAttr  a == dbAttr  b
    && a ^. dbSegmentsL.towardsB.bsAcceptL
    && b ^. dbSegmentsL.towardsA.bsOfferL
    && not (a ^. dbSegmentsL.towardsB.bsDrawL) -- don't bother doing an update if we don't need to
    = Just (a & dbSegmentsL.towardsB.bsDrawL .~ True)
    | otherwise = Nothing

catDynBorders
    :: Lens' (Edges BorderSegment) BorderSegment
    -> Lens' (Edges BorderSegment) BorderSegment
    -> I.IMap DynBorder
    -> I.IMap DynBorder
    -> I.IMap DynBorder
catDynBorders towardsA towardsB am bm = I.mapMaybe id
    $ I.intersectionWith (catDynBorder towardsA towardsB) am bm

-- | Given borders that should be placed next to each other (the first argument
-- on the right or bottom, and the second argument on the left or top), compute
-- new borders and the rewrites that should be done along the edges of the two
-- images to keep the image in synch with the border information.
--
-- The input borders are assumed to be disjoint. This property is not checked.
catBorders
    :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image)
    => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border)
catBorders br r l = if lCoord + 1 == rCoord
    then ((lRe, rRe), lr')
    else ((I.empty, I.empty), lr)
    where
    lr     = BM.expand (BM.coordinates r) l `BM.unsafeUnion`
             BM.expand (BM.coordinates l) r
    lr'    = id
           . mergeIMap lCoord lIMap'
           . mergeIMap rCoord rIMap'
           $ lr
    lCoord = BM.coordinates l ^. hiPrimary br
    rCoord = BM.coordinates r ^. loPrimary br
    lIMap  = lookupPrimary br lCoord l
    rIMap  = lookupPrimary br rCoord r
    lIMap' = catDynBorders (loPrimary br) (hiPrimary br) lIMap rIMap
    rIMap' = catDynBorders (hiPrimary br) (loPrimary br) rIMap lIMap
    lRe    = renderDynBorder <$> lIMap'
    rRe    = renderDynBorder <$> rIMap'
    mergeIMap p imap bm = F.foldl'
        (\bm' (s,v) -> insertSecondary br (locationFromPrimarySecondary br p s) v bm')
        bm
        (I.unsafeToAscList imap)

-- | Given a direction to concatenate borders in, and the border information
-- itself (which list is assumed to be already shifted so that borders do not
-- overlap and are strictly increasing in the primary direction), produce: a
-- list of rewrites for the lo and hi directions of each border, respectively,
-- and the borders describing the fully concatenated object.
catAllBorders ::
    BoxRenderer n ->
    [BM.BorderMap DynBorder] ->
    ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder)
catAllBorders _ [] = ([], BM.empty)
catAllBorders br (bm:bms) = (zip ([I.empty]++los) (his++[I.empty]), bm') where
    (rewrites, bm') = runState (traverse (state . catBorders br) bms) bm
    (his, los) = unzip rewrites

rewriteEdge ::
    (Int -> V.Image -> V.Image) ->
    (Int -> V.Image -> V.Image) ->
    ([V.Image] -> V.Image) ->
    I.IMap V.Image -> V.Image -> V.Image
rewriteEdge splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where

    -- convert absolute positions into relative ones
    offsets _ [] = []
    offsets n ((n', r):nrs) = (n'-n, r) : offsets (n'+I.len r) nrs

    go [] old = [old]
    -- TODO: might be nice to construct this image with fill rather than
    -- replicate+char
    go ((lo, I.Run len new):nrs) old
        =  [splitLo lo old]
        ++ replicate len new
        ++ go nrs (splitHi (lo+len) old)

rewriteImage :: BoxRenderer n -> (I.IMap V.Image, I.IMap V.Image) -> V.Image -> V.Image
rewriteImage br (loRewrite, hiRewrite) old = rewriteHi . rewriteLo $ old where
    size = imagePrimary br old
    go = rewriteEdge (splitLoSecondary br) (splitHiSecondary br) (concatenateSecondary br)
    rewriteLo img
        | I.null loRewrite = img
        | otherwise = concatenatePrimary br
            [ go loRewrite (splitLoPrimary br 1 img)
            , splitHiPrimary br 1 img
            ]
    rewriteHi img
        | I.null hiRewrite = img
        | otherwise = concatenatePrimary br
            [ splitLoPrimary br (size-1) img
            , go hiRewrite (splitHiPrimary br (size-1) img)
            ]

-- | Limit the space available to the specified widget to the specified
-- number of columns. This is important for constraining the horizontal
-- growth of otherwise-greedy widgets. This is non-greedy horizontally
-- and defers to the limited widget vertically.
hLimit :: Int -> Widget n -> Widget n
hLimit w p =
    Widget Fixed (vSize p) $
      withReaderT (availWidthL %~ (min w)) $ render $ cropToContext p

-- | Limit the space available to the specified widget to the specified
-- percentage of available width, as a value between 0 and 100
-- inclusive. Values outside the valid range will be clamped to the
-- range endpoints. This is important for constraining the horizontal
-- growth of otherwise-greedy widgets. This is non-greedy horizontally
-- and defers to the limited widget vertically.
hLimitPercent :: Int -> Widget n -> Widget n
hLimitPercent w' p =
    Widget Fixed (vSize p) $ do
      let w = clamp 0 100 w'
      ctx <- getContext
      let usableWidth = ctx^.availWidthL
          widgetWidth = round (toRational usableWidth * (toRational w / 100))
      withReaderT (availWidthL %~ (min widgetWidth)) $ render $ cropToContext p

-- | Limit the space available to the specified widget to the specified
-- number of rows. This is important for constraining the vertical
-- growth of otherwise-greedy widgets. This is non-greedy vertically and
-- defers to the limited widget horizontally.
vLimit :: Int -> Widget n -> Widget n
vLimit h p =
    Widget (hSize p) Fixed $
      withReaderT (availHeightL %~ (min h)) $ render $ cropToContext p

-- | Limit the space available to the specified widget to the specified
-- percentage of available height, as a value between 0 and 100
-- inclusive. Values outside the valid range will be clamped to the
-- range endpoints. This is important for constraining the vertical
-- growth of otherwise-greedy widgets. This is non-greedy vertically and
-- defers to the limited widget horizontally.
vLimitPercent :: Int -> Widget n -> Widget n
vLimitPercent h' p =
    Widget (hSize p) Fixed $ do
      let h = clamp 0 100 h'
      ctx <- getContext
      let usableHeight = ctx^.availHeightL
          widgetHeight = round (toRational usableHeight * (toRational h / 100))
      withReaderT (availHeightL %~ (min widgetHeight)) $ render $ cropToContext p

-- | Set the rendering context height and width for this widget. This
-- is useful for relaxing the rendering size constraints on e.g. layer
-- widgets where cropping to the screen size is undesirable.
setAvailableSize :: (Int, Int) -> Widget n -> Widget n
setAvailableSize (w, h) p =
    Widget Fixed Fixed $
      withReaderT (\c -> c & availHeightL .~ h & availWidthL .~ w) $
        render $ cropToContext p

-- | When drawing the specified widget, set the current attribute used
-- for drawing to the one with the specified name. Note that the widget
-- may use further calls to 'withAttr' to override this; if you really
-- want to prevent that, use 'forceAttr'. Attributes used this way still
-- get merged hierarchically and still fall back to the attribute map's
-- default attribute. If you want to change the default attribute, use
-- 'withDefAttr'.
withAttr :: AttrName -> Widget n -> Widget n
withAttr an p =
    Widget (hSize p) (vSize p) $
      withReaderT (& ctxAttrNameL .~ an) (render p)

-- | Update the attribute map while rendering the specified widget: set
-- its new default attribute to the one that we get by looking up the
-- specified attribute name in the map and then modifying it with the
-- specified function.
modifyDefAttr :: (V.Attr -> V.Attr) -> Widget n -> Widget n
modifyDefAttr f p =
    Widget (hSize p) (vSize p) $ do
        c <- getContext
        withReaderT (& ctxAttrMapL %~ (setDefaultAttr (f $ getDefaultAttr (c^.ctxAttrMapL)))) (render p)

-- | Update the attribute map while rendering the specified widget: set
-- its new default attribute to the one that we get by looking up the
-- specified attribute name in the map.
withDefAttr :: AttrName -> Widget n -> Widget n
withDefAttr an p =
    Widget (hSize p) (vSize p) $ do
        c <- getContext
        withReaderT (& ctxAttrMapL %~ (setDefaultAttr (attrMapLookup an (c^.ctxAttrMapL)))) (render p)

-- | When rendering the specified widget, update the attribute map with
-- the specified transformation.
updateAttrMap :: (AttrMap -> AttrMap) -> Widget n -> Widget n
updateAttrMap f p =
    Widget (hSize p) (vSize p) $
        withReaderT (& ctxAttrMapL %~ f) (render p)

-- | When rendering the specified widget, force all attribute lookups
-- in the attribute map to use the value currently assigned to the
-- specified attribute name.
forceAttr :: AttrName -> Widget n -> Widget n
forceAttr an p =
    Widget (hSize p) (vSize p) $ do
        c <- getContext
        withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p)

-- | Override the lookup of 'targetName' to return the attribute value
-- associated with 'fromName' when rendering the specified widget.
-- See also 'mapAttrName'.
overrideAttr :: AttrName -> AttrName -> Widget n -> Widget n
overrideAttr targetName fromName =
    updateAttrMap (mapAttrName fromName targetName)

-- | Build a widget directly from a raw Vty image.
raw :: V.Image -> Widget n
raw img = Widget Fixed Fixed $ return $ emptyResult & imageL .~ img

-- | Translate the specified widget by the specified offset amount.
-- Defers to the translated widget for growth policy.
translateBy :: Location -> Widget n -> Widget n
translateBy off p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      return $ addResultOffset off
             $ result & imageL %~ (V.translate (off^.locationColumnL) (off^.locationRowL))

-- | Crop the specified widget on the left by the specified number of
-- columns. Defers to the cropped widget for growth policy.
cropLeftBy :: Int -> Widget n -> Widget n
cropLeftBy cols p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      let amt = V.imageWidth (result^.imageL) - cols
          cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img
      return $ addResultOffset (Location (-1 * cols, 0))
             $ result & imageL %~ cropped

-- | Crop the specified widget on the right by the specified number of
-- columns. Defers to the cropped widget for growth policy.
cropRightBy :: Int -> Widget n -> Widget n
cropRightBy cols p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      let amt = V.imageWidth (result^.imageL) - cols
          cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img
      return $ result & imageL %~ cropped

-- | Crop the specified widget on the top by the specified number of
-- rows. Defers to the cropped widget for growth policy.
cropTopBy :: Int -> Widget n -> Widget n
cropTopBy rows p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      let amt = V.imageHeight (result^.imageL) - rows
          cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img
      return $ addResultOffset (Location (0, -1 * rows))
             $ result & imageL %~ cropped

-- | Crop the specified widget on the bottom by the specified number of
-- rows. Defers to the cropped widget for growth policy.
cropBottomBy :: Int -> Widget n -> Widget n
cropBottomBy rows p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      let amt = V.imageHeight (result^.imageL) - rows
          cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img
      return $ result & imageL %~ cropped

-- | When rendering the specified widget, also register a cursor
-- positioning request using the specified name and location.
showCursor :: n -> Location -> Widget n -> Widget n
showCursor n cloc p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      return $ result & cursorsL %~ (CursorLocation cloc (Just n):)

hRelease :: Widget n -> Maybe (Widget n)
hRelease p =
    case hSize p of
        Fixed -> Just $ Widget Greedy (vSize p) $
                        withReaderT (& availWidthL .~ unrestricted) (render p)
        Greedy -> Nothing

vRelease :: Widget n -> Maybe (Widget n)
vRelease p =
    case vSize p of
        Fixed -> Just $ Widget (hSize p) Greedy $
                        withReaderT (& availHeightL .~ unrestricted) (render p)
        Greedy -> Nothing

-- | Render the specified widget. If the widget has an entry in the
-- rendering cache using the specified name as the cache key, use the
-- rendered version from the cache instead. If not, render the widget
-- and update the cache.
--
-- See also 'invalidateCacheEntry'.
cached :: (Ord n) => n -> Widget n -> Widget n
cached n w =
    Widget (hSize w) (vSize w) $ do
        result <- cacheLookup n
        case result of
            Just prevResult -> return prevResult
            Nothing  -> do
                wResult <- render w
                cacheUpdate n wResult
                return wResult

cacheLookup :: (Ord n) => n -> RenderM n (Maybe (Result n))
cacheLookup n = do
    cache <- lift $ gets (^.renderCacheL)
    return $ M.lookup n cache

cacheUpdate :: (Ord n) => n -> Result n -> RenderM n ()
cacheUpdate n r = lift $ modify (& renderCacheL %~ M.insert n r)

-- | Render the specified widget in a named viewport with the
-- specified type. This permits widgets to be scrolled without being
-- scrolling-aware. To make the most use of viewports, the specified
-- widget should use the 'visible' combinator to make a "visibility
-- request". This viewport combinator will then translate the resulting
-- rendering to make the requested region visible. In addition, the
-- 'Brick.Main.EventM' monad provides primitives to scroll viewports
-- created by this function if 'visible' is not what you want.
--
-- If a viewport receives more than one visibility request, then the
-- visibility requests are merged with the inner visibility request
-- taking preference. If a viewport receives more than one scrolling
-- request from 'Brick.Main.EventM', all are honored in the order in
-- which they are received.
viewport :: (Ord n, Show n)
         => n
         -- ^ The name of the viewport (must be unique and stable for
         -- reliable behavior)
         -> ViewportType
         -- ^ The type of viewport (indicates the permitted scrolling
         -- direction)
         -> Widget n
         -- ^ The widget to be rendered in the scrollable viewport
         -> Widget n
viewport vpname typ p =
    clickable vpname $ Widget Greedy Greedy $ do
      -- Observe the viewport name so we can detect multiple uses of the
      -- name.
      let observeName :: (Ord n, Show n) => n -> RenderM n ()
          observeName n = do
              observed <- use observedNamesL
              case S.member n observed of
                  False -> observedNamesL %= S.insert n
                  True ->
                      error $ "Error: while rendering the interface, the name " <> show n <>
                              " was seen more than once. You should ensure that all of the widgets " <>
                              "in each interface have unique name values. This means either " <>
                              "using a different name type or adding constructors to your " <>
                              "existing one and using those to name your widgets.  For more " <>
                              "information, see the \"Resource Names\" section of the Brick User Guide."

      observeName vpname

      -- Update the viewport size.
      c <- getContext
      let newVp = VP 0 0 newSize
          newSize = (c^.availWidthL, c^.availHeightL)
          doInsert (Just vp) = Just $ vp & vpSize .~ newSize
          doInsert Nothing = Just newVp

      lift $ modify (& viewportMapL %~ (M.alter doInsert vpname))

      -- Then render the viewport content widget with the rendering
      -- layout constraint released (but raise an exception if we are
      -- asked to render an infinitely-sized widget in the viewport's
      -- scrolling dimension)
      let release = case typ of
            Vertical -> vRelease
            Horizontal -> hRelease
            Both -> vRelease >=> hRelease
          released = case release p of
            Just w -> w
            Nothing -> case typ of
                Vertical -> error $ "tried to embed an infinite-height " <>
                                    "widget in vertical viewport " <> (show vpname)
                Horizontal -> error $ "tried to embed an infinite-width " <>
                                      "widget in horizontal viewport " <> (show vpname)
                Both -> error $ "tried to embed an infinite-width or " <>
                                "infinite-height widget in 'Both' type " <>
                                "viewport " <> (show vpname)

      initialResult <- render released

      -- If the rendering state includes any scrolling requests for this
      -- viewport, apply those
      reqs <- lift $ gets $ (^.rsScrollRequestsL)
      let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs
      when (not $ null relevantRequests) $ do
          mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname))
          case mVp of
              Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map"
              Just vp -> do
                  let updatedVp = applyRequests relevantRequests vp
                      applyRequests [] v = v
                      applyRequests (rq:rqs) v =
                          case typ of
                              Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v
                              Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v
                              Both -> scrollTo Horizontal rq (initialResult^.imageL) $
                                      scrollTo Vertical rq (initialResult^.imageL) $
                                      applyRequests rqs v
                  lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp))

      -- If the sub-rendering requested visibility, update the scroll
      -- state accordingly
      when (not $ null $ initialResult^.visibilityRequestsL) $ do
          mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname))
          case mVp of
              Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map"
              Just vp -> do
                  let rqs = initialResult^.visibilityRequestsL
                      updateVp vp' rq = case typ of
                          Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp'
                          Horizontal -> scrollToView typ rq vp'
                          Vertical -> scrollToView typ rq vp'
                  lift $ modify (& viewportMapL %~ (M.insert vpname $ foldl updateVp vp rqs))

      -- If the size of the rendering changes enough to make the
      -- viewport offsets invalid, reset them
      mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname))
      vp <- case mVp of
          Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map"
          Just v -> return v

      let img = initialResult^.imageL
          fixTop v = if V.imageHeight img < v^.vpSize._2
                   then v & vpTop .~ 0
                   else v
          fixLeft v = if V.imageWidth img < v^.vpSize._1
                   then v & vpLeft .~ 0
                   else v
          updateVp = case typ of
              Both -> fixLeft . fixTop
              Horizontal -> fixLeft
              Vertical -> fixTop
      lift $ modify (& viewportMapL %~ (M.insert vpname (updateVp vp)))

      -- Get the viewport state now that it has been updated.
      mVpFinal <- lift $ gets (M.lookup vpname . (^.viewportMapL))
      vpFinal <- case mVpFinal of
          Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map"
          Just v -> return v

      -- Then perform a translation of the sub-rendering to fit into the
      -- viewport
      translated <- render $ translateBy (Location (-1 * vpFinal^.vpLeft, -1 * vpFinal^.vpTop))
                           $ Widget Fixed Fixed $ return initialResult

      -- Return the translated result with the visibility requests
      -- discarded
      let translatedSize = ( translated^.imageL.to V.imageWidth
                           , translated^.imageL.to V.imageHeight
                           )
      case translatedSize of
          (0, 0) -> do
              let spaceFill = V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)
              return $ translated & imageL .~ spaceFill
                                  & visibilityRequestsL .~ mempty
                                  & extentsL .~ mempty
          _ -> render $ cropToContext
                      $ padBottom Max
                      $ padRight Max
                      $ Widget Fixed Fixed
                      $ return $ translated & visibilityRequestsL .~ mempty

-- | Given a name, obtain the viewport for that name by consulting the
-- viewport map in the rendering monad. NOTE! Some care must be taken
-- when calling this function, since it only returns useful values
-- after the viewport in question has been rendered. If you call this
-- function during rendering before a viewport has been rendered, you
-- may get nothing or you may get a stale version of the viewport. This
-- is because viewports are updated during rendering and the one you are
-- interested in may not have been rendered yet. So if you want to use
-- this, be sure you know what you are doing.
unsafeLookupViewport :: (Ord n) => n -> RenderM n (Maybe Viewport)
unsafeLookupViewport name = lift $ gets (M.lookup name . (^.viewportMapL))

scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport
scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'"
scrollTo Vertical req img vp = vp & vpTop .~ newVStart
    where
        newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt
        adjustedAmt = case req of
            VScrollBy amt -> vp^.vpTop + amt
            VScrollPage Up -> vp^.vpTop - vp^.vpSize._2
            VScrollPage Down -> vp^.vpTop + vp^.vpSize._2
            VScrollToBeginning -> 0
            VScrollToEnd -> V.imageHeight img - vp^.vpSize._2
            SetTop i -> i
            _ -> vp^.vpTop
scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart
    where
        newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt
        adjustedAmt = case req of
            HScrollBy amt -> vp^.vpLeft + amt
            HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1
            HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1
            HScrollToBeginning -> 0
            HScrollToEnd -> V.imageWidth img - vp^.vpSize._1
            SetLeft i -> i
            _ -> vp^.vpLeft

scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport
scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport"
scrollToView Vertical rq vp = vp & vpTop .~ newVStart
    where
        curStart = vp^.vpTop
        curEnd = curStart + vp^.vpSize._2
        reqStart = rq^.vrPositionL.locationRowL

        reqEnd = rq^.vrPositionL.locationRowL + rq^.vrSizeL._2
        newVStart :: Int
        newVStart = if reqStart < vStartEndVisible
                   then reqStart
                   else vStartEndVisible
        vStartEndVisible = if reqEnd < curEnd
                           then curStart
                           else curStart + (reqEnd - curEnd)
scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart
    where
        curStart = vp^.vpLeft
        curEnd = curStart + vp^.vpSize._1
        reqStart = rq^.vrPositionL.locationColumnL

        reqEnd = rq^.vrPositionL.locationColumnL + rq^.vrSizeL._1
        newHStart :: Int
        newHStart = if reqStart < hStartEndVisible
                   then reqStart
                   else hStartEndVisible
        hStartEndVisible = if reqEnd < curEnd
                           then curStart
                           else curStart + (reqEnd - curEnd)

-- | Request that the specified widget be made visible when it is
-- rendered inside a viewport. This permits widgets (whose sizes and
-- positions cannot be known due to being embedded in arbitrary layouts)
-- to make a request for a parent viewport to locate them and scroll
-- enough to put them in view. This, together with 'viewport', is what
-- makes the text editor and list widgets possible without making them
-- deal with the details of scrolling state management.
--
-- This does nothing if not rendered in a viewport.
visible :: Widget n -> Widget n
visible p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      let imageSize = ( result^.imageL.to V.imageWidth
                      , result^.imageL.to V.imageHeight
                      )
      -- The size of the image to be made visible in a viewport must have
      -- non-zero size in both dimensions.
      return $ if imageSize^._1 > 0 && imageSize^._2 > 0
               then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :)
               else result

-- | Similar to 'visible', request that a region (with the specified
-- 'Location' as its origin and 'V.DisplayRegion' as its size) be made
-- visible when it is rendered inside a viewport. The 'Location' is
-- relative to the specified widget's upper-left corner of (0, 0).
--
-- This does nothing if not rendered in a viewport.
visibleRegion :: Location -> V.DisplayRegion -> Widget n -> Widget n
visibleRegion vrloc sz p =
    Widget (hSize p) (vSize p) $ do
      result <- render p
      -- The size of the image to be made visible in a viewport must have
      -- non-zero size in both dimensions.
      return $ if sz^._1 > 0 && sz^._2 > 0
               then result & visibilityRequestsL %~ (VR vrloc sz :)
               else result

-- | Horizontal box layout: put the specified widgets next to each other
-- in the specified order. Defers growth policies to the growth policies
-- of both widgets.  This operator is a binary version of 'hBox'.
{-# NOINLINE (<+>) #-}
(<+>) :: Widget n
      -- ^ Left
      -> Widget n
      -- ^ Right
      -> Widget n
(<+>) a b = hBox [a, b]

-- | Vertical box layout: put the specified widgets one above the other
-- in the specified order. Defers growth policies to the growth policies
-- of both widgets.  This operator is a binary version of 'vBox'.
{-# NOINLINE (<=>) #-}
(<=>) :: Widget n
      -- ^ Top
      -> Widget n
      -- ^ Bottom
      -> Widget n
(<=>) a b = vBox [a, b]

{-# RULES
"baseHbox" forall a b   . a <+> b                 = hBox [a, b]
"hBox2"    forall as bs . hBox [hBox as, hBox bs] = hBox (as ++ bs)
"hboxL"    forall as b  . hBox [hBox as, b]       = hBox (as ++ [b])
"hboxR"    forall a bs  . hBox [a, hBox bs]       = hBox (a : bs)
"baseVbox" forall a b   . a <=> b                 = vBox [a, b]
"vBox2"    forall as bs . vBox [vBox as, vBox bs] = vBox (as ++ bs)
"vboxL"    forall as b  . vBox [vBox as, b]       = vBox (as ++ [b])
"vboxR"    forall a bs  . vBox [a, vBox bs]       = vBox (a : bs)
  #-}