content: {-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-}
  -- |This module provides visual borders to be placed between and
  -- around widgets.  Border widgets in this module use the active
  -- 'Skin' in the 'RenderContext'.
  module Graphics.Vty.Widgets.Borders
      ( HasBorderAttr(..)
      , Bordered
      , HBorder
      , VBorder
      -- * Border Widget Constructors
      , vBorder
      , hBorder
      , bordered
      -- * Setting Attributes and Labels
      , withBorderAttribute
      , withHBorderLabel
      , withBorderedLabel
      , setHBorderLabel
      , setBorderedLabel
      )
  where
  
  import qualified Data.Text as T
  
  import Graphics.Vty hiding (regionHeight, regionWidth)
  import Graphics.Vty.Widgets.Core
  import Graphics.Vty.Widgets.Box
  import Graphics.Vty.Widgets.Text
  import Graphics.Vty.Widgets.Util
  import Graphics.Vty.Widgets.Skins
  
  -- |The class of types with a border attribute, which differs from the
  -- normal and focused attributes.
  class HasBorderAttr a where
      setBorderAttribute :: a -> Attr -> IO ()
  
  data HBorder = HBorder Attr T.Text
                 deriving (Show)
  
  instance HasBorderAttr (Widget HBorder) where
      setBorderAttribute t a =
          updateWidgetState t $ \(HBorder a' s) -> HBorder (mergeAttr a a') s
  
  -- | Sets the border attribute of a thing with a border attribute.
  withBorderAttribute :: (HasBorderAttr a) => Attr -> a -> IO a
  withBorderAttribute att w = setBorderAttribute w att >> return w
  
  -- | Adds a label to a horizontal border.  The label will be
  -- horizontally centered.
  withHBorderLabel :: T.Text -> Widget HBorder -> IO (Widget HBorder)
  withHBorderLabel label w = setHBorderLabel w label >> return w
  
  -- | Adds a label to a horizontal border.  The label will be
  -- horizontally centered.
  setHBorderLabel :: Widget HBorder -> T.Text -> IO ()
  setHBorderLabel w label =
      updateWidgetState w $ \(HBorder a _) -> HBorder a label
  
  -- | Adds a label to the top border of a bordered widget.  The label
  -- will be horizontally centered.
  withBorderedLabel :: T.Text -> Widget (Bordered a) -> IO (Widget (Bordered a))
  withBorderedLabel label w = setBorderedLabel w label >> return w
  
  -- | Adds a label to the top border of a bordered widget.  The label
  -- will be horizontally centered.
  setBorderedLabel :: Widget (Bordered a) -> T.Text -> IO ()
  setBorderedLabel w label =
      updateWidgetState w $ \(Bordered a ch _) -> Bordered a ch label
  
  -- |Create a single-row horizontal border using the specified
  -- attribute and character.
  hBorder :: IO (Widget HBorder)
  hBorder = do
    let initSt = HBorder defAttr T.empty
    wRef <- newWidget initSt $ \w ->
        w { growHorizontal_ = const $ return True
          , render_ = renderHBorder
          , getCursorPosition_ = const $ return Nothing
          }
    return wRef
  
  renderHBorder :: Widget HBorder -> DisplayRegion -> RenderContext -> IO Image
  renderHBorder _ (0, _) _ = return emptyImage
  renderHBorder _ (_, 0) _ = return emptyImage
  renderHBorder this s ctx = do
    HBorder attr str <- getState this
    let attr' = mergeAttrs [ overrideAttr ctx
                           , attr
                           , normalAttr ctx
                           ]
        ch = skinHorizontal $ skin ctx
        noTitle = T.pack $ replicate (fromEnum $ regionWidth s) ch
  
    wStr <- case T.null str of
              True -> return noTitle
              False -> do
                let title = T.concat [ T.pack " "
                                     , str
                                     , T.pack " "
                                     ]
                case (textWidth title) > (Phys $ fromEnum $ regionWidth s) of
                  True -> return noTitle
                  False -> do
                         let remaining = (Phys $ fromEnum $ regionWidth s) - (textWidth title)
                             Phys side1 = remaining `div` Phys 2
                             side2 = if remaining `mod` Phys 2 == Phys 0 then side1 else side1 + 1
                         return $ T.concat [ T.pack $ replicate side1 ch
                                           , title
                                           , T.pack $ replicate side2 ch
                                           ]
  
    w <- plainTextWithAttrs [(wStr, attr')]
    render w s ctx
  
  data VBorder = VBorder Attr
                 deriving (Show)
  
  instance HasBorderAttr (Widget VBorder) where
      setBorderAttribute t a =
          updateWidgetState t $ \(VBorder a') -> VBorder (mergeAttr a a')
  
  -- |Create a single-column vertical border using the specified
  -- attribute and character.
  vBorder :: IO (Widget VBorder)
  vBorder = do
    let initSt = VBorder defAttr
    wRef <- newWidget initSt $ \w ->
        w { growVertical_ = const $ return True
          , getCursorPosition_ = const $ return Nothing
          , render_ = \this s ctx -> do
                     VBorder attr <- getState this
                     let attr' = mergeAttrs [ overrideAttr ctx
                                            , attr
                                            , normalAttr ctx
                                            ]
                     return $ charFill attr' (skinVertical $ skin ctx) 1 (regionHeight s)
          }
    return wRef
  
  data Bordered a = (Show a) => Bordered Attr (Widget a) T.Text
  
  instance Show (Bordered a) where
      show (Bordered attr _ l) = concat [ "Bordered { attr = "
                                        , show attr
                                        , ", label = "
                                        , show l
                                        , ", ... }"
                                        ]
  
  instance HasBorderAttr (Widget (Bordered a)) where
      setBorderAttribute t a =
          updateWidgetState t $ \(Bordered a' ch s) -> Bordered (mergeAttr a a') ch s
  
  -- |Wrap a widget in a bordering box.
  bordered :: (Show a) => Widget a -> IO (Widget (Bordered a))
  bordered child = do
    let initSt = Bordered defAttr child T.empty
    wRef <- newWidget initSt $ \w ->
        w { growVertical_ = const $ growVertical child
          , growHorizontal_ = const $ growHorizontal child
  
          , keyEventHandler =
              \this key mods -> do
                Bordered _ ch _ <- getState this
                handleKeyEvent ch key mods
  
          , render_ =
              \this s ctx -> do
                st <- getState this
                drawBordered st s ctx
  
          , setCurrentPosition_ =
              \this pos -> do
                Bordered _ ch _ <- getState this
                let chPos = pos `plusWidth` 1 `plusHeight` 1
                setCurrentPosition ch chPos
          }
    wRef `relayFocusEvents` child
    wRef `relayKeyEvents` child
    return wRef
  
  drawBordered :: (Show a) =>
                  Bordered a -> DisplayRegion -> RenderContext -> IO Image
  drawBordered this s ctx
      | regionWidth s < 2 || regionHeight s < 2 = return emptyImage
      | otherwise = do
    let Bordered attr child label = this
        attr' = mergeAttrs [ overrideAttr ctx
                           , attr
                           , normalAttr ctx
                           ]
        sk = skin ctx
  
    -- Render the contained widget with enough room to draw borders.
    -- Then, use the size of the rendered widget to constrain the space
    -- used by the (expanding) borders.
    let constrained = (regionWidth s - 2, regionHeight s - 2)
  
    childImage <- render child constrained ctx
  
    let adjusted = ( imageWidth childImage + 2
                   , imageHeight childImage
                   )
  
    tlCorner <- plainText (T.singleton $ skinCornerTL sk)
                >>= withNormalAttribute attr'
    trCorner <- plainText (T.singleton $ skinCornerTR sk)
                >>= withNormalAttribute attr'
    blCorner <- plainText (T.singleton $ skinCornerBL sk)
                >>= withNormalAttribute attr'
    brCorner <- plainText (T.singleton $ skinCornerBR sk)
                >>= withNormalAttribute attr'
  
    hb <- hBorder >>= withHBorderLabel label
    setBorderAttribute hb attr'
  
    topWidget <- hBox tlCorner =<< hBox hb trCorner
    top <- render topWidget adjusted ctx
  
    hb2 <- hBorder
    bottomWidget <- hBox blCorner =<< hBox hb2 brCorner
    bottom <- render bottomWidget adjusted ctx
  
    vb <- vBorder
    setBorderAttribute vb attr'
  
    leftRight <- render vb adjusted ctx
  
    let middle = horizCat [leftRight, childImage, leftRight]
  
    return $ vertCat [top, middle, bottom]
  