{-|
Module      : Monomer.Widgets.Singles.SeparatorLine
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

SeparatorLine is used for adding a separator line between two widgets. It adapts
to the active layout direction, creating a vertical line on a horizontal layout
and viceversa.

The line has the provided width in the direction orthogonal to the layout
direction, and takes all the available space in the other direction. In case of
wanting a shorter line, padding should be used.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.SeparatorLine (
  -- * Configuration
  SeparatorLineCfg,
  -- * Constructors
  separatorLine,
  separatorLine_
) where

import Control.Applicative ((<|>))
import Control.Lens ((^.))
import Data.Default
import Data.Maybe
import Data.Tuple

import Monomer.Widgets.Single

import qualified Monomer.Core.Lens as L

{-|
Configuration options for separatorLine:

- 'width': the max width of the line.
- 'resizeFactor': flexibility to have more or less spaced assigned.
-}
data SeparatorLineCfg = SeparatorLineCfg {
  SeparatorLineCfg -> Maybe Double
_slcWidth :: Maybe Double,
  SeparatorLineCfg -> Maybe Double
_slcFactor :: Maybe Double
}

instance Default SeparatorLineCfg where
  def :: SeparatorLineCfg
def = SeparatorLineCfg :: Maybe Double -> Maybe Double -> SeparatorLineCfg
SeparatorLineCfg {
    _slcWidth :: Maybe Double
_slcWidth = Maybe Double
forall a. Maybe a
Nothing,
    _slcFactor :: Maybe Double
_slcFactor = Maybe Double
forall a. Maybe a
Nothing
  }

instance Semigroup SeparatorLineCfg where
  <> :: SeparatorLineCfg -> SeparatorLineCfg -> SeparatorLineCfg
(<>) SeparatorLineCfg
s1 SeparatorLineCfg
s2 = SeparatorLineCfg :: Maybe Double -> Maybe Double -> SeparatorLineCfg
SeparatorLineCfg {
    _slcWidth :: Maybe Double
_slcWidth = SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
s1,
    _slcFactor :: Maybe Double
_slcFactor = SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
s1
  }

instance Monoid SeparatorLineCfg where
  mempty :: SeparatorLineCfg
mempty = SeparatorLineCfg
forall a. Default a => a
def

instance CmbWidth SeparatorLineCfg where
  width :: Double -> SeparatorLineCfg
width Double
w = SeparatorLineCfg
forall a. Default a => a
def {
    _slcWidth :: Maybe Double
_slcWidth = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }

instance CmbResizeFactor SeparatorLineCfg where
  resizeFactor :: Double -> SeparatorLineCfg
resizeFactor Double
f = SeparatorLineCfg
forall a. Default a => a
def {
    _slcFactor :: Maybe Double
_slcFactor = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
f
  }

-- | Creates a separatorLine widget.
separatorLine :: WidgetNode s e
separatorLine :: WidgetNode s e
separatorLine = [SeparatorLineCfg] -> WidgetNode s e
forall s e. [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ [SeparatorLineCfg]
forall a. Default a => a
def

-- | Creates a separatorLine widget. Accepts config.
separatorLine_ :: [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ :: [SeparatorLineCfg] -> WidgetNode s e
separatorLine_ [SeparatorLineCfg]
configs = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"separatorLine" Widget s e
forall s e. Widget s e
widget where
  config :: SeparatorLineCfg
config = [SeparatorLineCfg] -> SeparatorLineCfg
forall a. Monoid a => [a] -> a
mconcat (Double -> SeparatorLineCfg
forall t. CmbResizeFactor t => Double -> t
resizeFactor Double
0 SeparatorLineCfg -> [SeparatorLineCfg] -> [SeparatorLineCfg]
forall a. a -> [a] -> [a]
: [SeparatorLineCfg]
configs)
  widget :: Widget s e
widget = SeparatorLineCfg -> Widget s e
forall s e. SeparatorLineCfg -> Widget s e
makeSeparatorLine SeparatorLineCfg
config

makeSeparatorLine :: SeparatorLineCfg -> Widget s e
makeSeparatorLine :: SeparatorLineCfg -> Widget s e
makeSeparatorLine !SeparatorLineCfg
config = Widget s e
forall s e. Widget s e
widget where
  widget :: Widget s e
widget = () -> Single s e () -> Widget s e
forall a s e. WidgetModel a => a -> Single s e a -> Widget s e
createSingle () Single s e ()
forall a. Default a => a
def {
    singleGetBaseStyle :: SingleGetBaseStyle s e
singleGetBaseStyle = SingleGetBaseStyle s e
forall s e p. WidgetEnv s e -> p -> Maybe Style
getBaseStyle,
    singleGetSizeReq :: SingleGetSizeReqHandler s e
singleGetSizeReq = SingleGetSizeReqHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq,
    singleRender :: SingleRenderHandler s e
singleRender = SingleRenderHandler s e
forall s e. WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render
  }

  getBaseStyle :: WidgetEnv s e -> p -> Maybe Style
getBaseStyle WidgetEnv s e
wenv p
node = Style -> Maybe Style
forall a. a -> Maybe a
Just Style
style where
    style :: Style
style = WidgetEnv s e -> Lens' ThemeState StyleState -> Style
forall s e. WidgetEnv s e -> Lens' ThemeState StyleState -> Style
collectTheme WidgetEnv s e
wenv forall s a. HasSeparatorLineStyle s a => Lens' s a
Lens' ThemeState StyleState
L.separatorLineStyle

  getSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
getSizeReq WidgetEnv s e
wenv WidgetNode s e
node = (SizeReq, SizeReq)
sizeReq where
    theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
    direction :: LayoutDirection
direction = WidgetEnv s e
wenv WidgetEnv s e
-> Getting LayoutDirection (WidgetEnv s e) LayoutDirection
-> LayoutDirection
forall s a. s -> Getting a s a -> a
^. Getting LayoutDirection (WidgetEnv s e) LayoutDirection
forall s a. HasLayoutDirection s a => Lens' s a
L.layoutDirection
    width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSeparatorLineWidth s a => Lens' s a
L.separatorLineWidth) (SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
config)
    factor :: Double
factor = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (SeparatorLineCfg -> Maybe Double
_slcFactor SeparatorLineCfg
config)

    isFixed :: Bool
isFixed = Double
factor Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.01
    flexSide :: SizeReq
flexSide = Double -> Double -> SizeReq
flexSize Double
10 Double
0.5
    fixedW :: SizeReq
fixedW = Double -> SizeReq
fixedSize Double
width
    flexW :: SizeReq
flexW = Double -> Double -> SizeReq
flexSize Double
width Double
factor
    expandW :: SizeReq
expandW = Double -> Double -> SizeReq
expandSize Double
width Double
factor

    sizeReq :: (SizeReq, SizeReq)
sizeReq
      | Bool
isFixed Bool -> Bool -> Bool
&& LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = (SizeReq
fixedW, SizeReq
fixedW)
      | Bool
isFixed Bool -> Bool -> Bool
&& LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = (SizeReq
fixedW, SizeReq
flexSide)
      | Bool
isFixed = (SizeReq
flexSide, SizeReq
fixedW)
      | LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = (SizeReq
expandW, SizeReq
expandW)
      | LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = (SizeReq
expandW, SizeReq
flexW)
      | Bool
otherwise = (SizeReq
flexW, SizeReq
expandW)

  render :: WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
render WidgetEnv s e
wenv WidgetNode s e
node Renderer
renderer = do
    Renderer -> IO ()
beginPath Renderer
renderer
    Renderer -> Color -> IO ()
setFillColor Renderer
renderer Color
fgColor
    Renderer -> Rect -> IO ()
renderRect Renderer
renderer Rect
lineRect
    Renderer -> IO ()
fill Renderer
renderer
    where
      theme :: ThemeState
theme = WidgetEnv s e -> WidgetNode s e -> ThemeState
forall s e. WidgetEnv s e -> WidgetNode s e -> ThemeState
currentTheme WidgetEnv s e
wenv WidgetNode s e
node
      style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
      direction :: LayoutDirection
direction = WidgetEnv s e
wenv WidgetEnv s e
-> Getting LayoutDirection (WidgetEnv s e) LayoutDirection
-> LayoutDirection
forall s a. s -> Getting a s a -> a
^. Getting LayoutDirection (WidgetEnv s e) LayoutDirection
forall s a. HasLayoutDirection s a => Lens' s a
L.layoutDirection
      fgColor :: Color
fgColor = StyleState -> Color
styleFgColor StyleState
style
      width :: Double
width = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (ThemeState
theme ThemeState -> Getting Double ThemeState Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double ThemeState Double
forall s a. HasSeparatorLineWidth s a => Lens' s a
L.separatorLineWidth) (SeparatorLineCfg -> Maybe Double
_slcWidth SeparatorLineCfg
config)

      Rect Double
cx Double
cy Double
cw Double
ch = WidgetNode s e -> StyleState -> Rect
forall s e. WidgetNode s e -> StyleState -> Rect
getContentArea WidgetNode s e
node StyleState
style
      lineW :: Double
lineW = Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
cw Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      lineH :: Double
lineH = Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
ch Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
width) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      lineRect :: Rect
lineRect
        | LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutNone = Double -> Double -> Double -> Double -> Rect
Rect Double
cx Double
cy Double
cw Double
ch
        | LayoutDirection
direction LayoutDirection -> LayoutDirection -> Bool
forall a. Eq a => a -> a -> Bool
== LayoutDirection
LayoutHorizontal = Double -> Double -> Double -> Double -> Rect
Rect Double
lineW Double
cy Double
width Double
ch
        | Bool
otherwise = Double -> Double -> Double -> Double -> Rect
Rect Double
cx Double
lineH Double
cw Double
width