{-# LANGUAGE Strict #-}
module Monomer.Widgets.Containers.Stack (
StackCfg,
hstack,
hstack_,
vstack,
vstack_,
assignStackAreas
) where
import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (%~))
import Data.Default
import Data.Foldable (toList)
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (<|), (|>))
import qualified Data.Sequence as Seq
import Monomer.Helper (applyFnList)
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
data StackCfg = StackCfg {
StackCfg -> Maybe Double
_stcChildSpacing :: Maybe Double,
StackCfg -> Maybe Bool
_stcIgnoreEmptyArea :: Maybe Bool,
StackCfg -> [SizeReqUpdater]
_stcSizeReqUpdater :: [SizeReqUpdater]
}
instance Default StackCfg where
def :: StackCfg
def = StackCfg {
_stcChildSpacing :: Maybe Double
_stcChildSpacing = forall a. Maybe a
Nothing,
_stcIgnoreEmptyArea :: Maybe Bool
_stcIgnoreEmptyArea = forall a. Maybe a
Nothing,
_stcSizeReqUpdater :: [SizeReqUpdater]
_stcSizeReqUpdater = []
}
instance Semigroup StackCfg where
<> :: StackCfg -> StackCfg -> StackCfg
(<>) StackCfg
s1 StackCfg
s2 = StackCfg {
_stcChildSpacing :: Maybe Double
_stcChildSpacing = StackCfg -> Maybe Double
_stcChildSpacing StackCfg
s2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StackCfg -> Maybe Double
_stcChildSpacing StackCfg
s1,
_stcIgnoreEmptyArea :: Maybe Bool
_stcIgnoreEmptyArea = StackCfg -> Maybe Bool
_stcIgnoreEmptyArea StackCfg
s2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StackCfg -> Maybe Bool
_stcIgnoreEmptyArea StackCfg
s1,
_stcSizeReqUpdater :: [SizeReqUpdater]
_stcSizeReqUpdater = StackCfg -> [SizeReqUpdater]
_stcSizeReqUpdater StackCfg
s1 forall a. Semigroup a => a -> a -> a
<> StackCfg -> [SizeReqUpdater]
_stcSizeReqUpdater StackCfg
s2
}
instance Monoid StackCfg where
mempty :: StackCfg
mempty = forall a. Default a => a
def
instance CmbChildSpacing StackCfg where
childSpacing_ :: Double -> StackCfg
childSpacing_ Double
spacing = forall a. Default a => a
def {
_stcChildSpacing :: Maybe Double
_stcChildSpacing = forall a. a -> Maybe a
Just Double
spacing
}
instance CmbIgnoreEmptyArea StackCfg where
ignoreEmptyArea_ :: Bool -> StackCfg
ignoreEmptyArea_ Bool
ignore = forall a. Default a => a
def {
_stcIgnoreEmptyArea :: Maybe Bool
_stcIgnoreEmptyArea = forall a. a -> Maybe a
Just Bool
ignore
}
instance CmbSizeReqUpdater StackCfg where
sizeReqUpdater :: SizeReqUpdater -> StackCfg
sizeReqUpdater SizeReqUpdater
updater = forall a. Default a => a
def {
_stcSizeReqUpdater :: [SizeReqUpdater]
_stcSizeReqUpdater = [SizeReqUpdater
updater]
}
hstack
:: (Traversable t)
=> t (WidgetNode s e)
-> WidgetNode s e
hstack :: forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
hstack t (WidgetNode s e)
children = forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
hstack_ forall a. Default a => a
def t (WidgetNode s e)
children
hstack_
:: (Traversable t)
=> [StackCfg]
-> t (WidgetNode s e)
-> WidgetNode s e
hstack_ :: forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
hstack_ [StackCfg]
configs t (WidgetNode s e)
children = WidgetNode s e
newNode where
config :: StackCfg
config = forall a. Monoid a => [a] -> a
mconcat [StackCfg]
configs
newNode :: WidgetNode s e
newNode = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"hstack" (forall s e. Bool -> StackCfg -> Widget s e
makeStack Bool
True StackCfg
config)
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Seq a -> a -> Seq a
(|>) forall a. Seq a
Empty t (WidgetNode s e)
children
vstack
:: (Traversable t)
=> t (WidgetNode s e)
-> WidgetNode s e
vstack :: forall (t :: * -> *) s e.
Traversable t =>
t (WidgetNode s e) -> WidgetNode s e
vstack t (WidgetNode s e)
children = forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
vstack_ forall a. Default a => a
def t (WidgetNode s e)
children
vstack_
:: (Traversable t)
=> [StackCfg]
-> t (WidgetNode s e)
-> WidgetNode s e
vstack_ :: forall (t :: * -> *) s e.
Traversable t =>
[StackCfg] -> t (WidgetNode s e) -> WidgetNode s e
vstack_ [StackCfg]
configs t (WidgetNode s e)
children = WidgetNode s e
newNode where
config :: StackCfg
config = forall a. Monoid a => [a] -> a
mconcat [StackCfg]
configs
newNode :: WidgetNode s e
newNode = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"vstack" (forall s e. Bool -> StackCfg -> Widget s e
makeStack Bool
False StackCfg
config)
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Seq a -> a -> Seq a
(|>) forall a. Seq a
Empty t (WidgetNode s e)
children
makeStack :: Bool -> StackCfg -> Widget s e
makeStack :: forall s e. Bool -> StackCfg -> Widget s e
makeStack Bool
isHorizontal StackCfg
config = forall {s} {e}. Widget s e
widget where
widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () forall a. Default a => a
def {
containerIgnoreEmptyArea :: Bool
containerIgnoreEmptyArea = Bool
ignoreEmptyArea,
containerLayoutDirection :: LayoutDirection
containerLayoutDirection = Bool -> LayoutDirection
getLayoutDirection Bool
isHorizontal,
containerUseCustomSize :: Bool
containerUseCustomSize = Bool
True,
containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = forall {p} {p} {s} {e}.
p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq,
containerResize :: ContainerResizeHandler s e
containerResize = forall {s} {e} {s} {e}.
WidgetEnv s e
-> WidgetNode s e
-> Rect
-> Seq (WidgetNode s e)
-> (WidgetResult s e, Seq Rect)
resize
}
isVertical :: Bool
isVertical = Bool -> Bool
not Bool
isHorizontal
ignoreEmptyArea :: Bool
ignoreEmptyArea = forall a. a -> Maybe a -> a
fromMaybe Bool
False (StackCfg -> Maybe Bool
_stcIgnoreEmptyArea StackCfg
config)
childSpacing :: Double
childSpacing = forall a. a -> Maybe a -> a
fromMaybe Double
0 (StackCfg -> Maybe Double
_stcChildSpacing StackCfg
config)
getSizeReq :: p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node Seq (WidgetNode s e)
children = (SizeReq, SizeReq)
newSizeReq where
sizeReqFns :: [SizeReqUpdater]
sizeReqFns = StackCfg -> [SizeReqUpdater]
_stcSizeReqUpdater StackCfg
config
vchildren :: Seq (WidgetNode s e)
vchildren = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
newSizeReqW :: SizeReq
newSizeReqW = forall {a}. Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
isHorizontal (WidgetNodeInfo -> SizeReq
_wniSizeReqW forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
newSizeReqH :: SizeReq
newSizeReqH = forall {a}. Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
isVertical (WidgetNodeInfo -> SizeReq
_wniSizeReqH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
newSizeReq :: (SizeReq, SizeReq)
newSizeReq = forall a. [a -> a] -> a -> a
applyFnList [SizeReqUpdater]
sizeReqFns (SizeReq
newSizeReqW, SizeReq
newSizeReqH)
getDimSizeReq :: Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
mainAxis a -> SizeReq
accessor Seq a
vchildren
| forall a. Seq a -> Bool
Seq.null Seq SizeReq
vreqs = Double -> SizeReq
fixedSize Double
0
| Bool
mainAxis = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SizeReq -> SizeReq -> SizeReq
sizeReqMergeSum Seq SizeReq
vreqs forall a b. a -> (a -> b) -> b
& forall s a. HasFixed s a => Lens' s a
L.fixed forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ Double
totalSpacing)
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SizeReq -> SizeReq -> SizeReq
sizeReqMergeMax Seq SizeReq
vreqs
where
vreqs :: Seq SizeReq
vreqs = a -> SizeReq
accessor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq a
vchildren
totalSpacing :: Double
totalSpacing = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Seq a -> Int
Seq.length Seq a
vchildren forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* Double
childSpacing
resize :: WidgetEnv s e
-> WidgetNode s e
-> Rect
-> Seq (WidgetNode s e)
-> (WidgetResult s e, Seq Rect)
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport Seq (WidgetNode s e)
children = (WidgetResult s e, Seq Rect)
resized where
style :: StyleState
style = forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
contentArea :: Rect
contentArea = forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
(Seq Rect
newVps, Double
newDim) = forall s e.
Bool
-> Rect -> Double -> Seq (WidgetNode s e) -> (Seq Rect, Double)
assignStackAreas Bool
isHorizontal Rect
contentArea Double
childSpacing Seq (WidgetNode s e)
children
newCa :: Rect
newCa
| Bool
isHorizontal = Rect
contentArea forall a b. a -> (a -> b) -> b
& forall s a. HasW s a => Lens' s a
L.w forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
newDim
| Bool
otherwise = Rect
contentArea forall a b. a -> (a -> b) -> b
& forall s a. HasH s a => Lens' s a
L.h forall s t a b. ASetter s t a b -> b -> s -> t
.~ Double
newDim
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasViewport s a => Lens' s a
L.viewport forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a -> a
fromMaybe Rect
newCa (StyleState -> Rect -> Maybe Rect
addOuterBounds StyleState
style Rect
newCa)
resized :: (WidgetResult s e, Seq Rect)
resized = (forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode, Seq Rect
newVps)
assignStackAreas
:: Bool
-> Rect
-> Double
-> Seq (WidgetNode s e)
-> (Seq Rect, Double)
assignStackAreas :: forall s e.
Bool
-> Rect -> Double -> Seq (WidgetNode s e) -> (Seq Rect, Double)
assignStackAreas Bool
isHorizontal Rect
contentArea Double
childSpacing Seq (WidgetNode s e)
children = (Seq Rect, Double)
result where
Rect Double
x Double
y Double
w Double
h = Rect
contentArea
mainSize :: Double
mainSize = if Bool
isHorizontal then Double
w else Double
h
mainStart :: Double
mainStart = if Bool
isHorizontal then Double
x else Double
y
rectSelector :: Rect -> Double
rectSelector
| Bool
isHorizontal = Rect -> Double
_rW
| Bool
otherwise = Rect -> Double
_rH
vchildren :: Seq (WidgetNode s e)
vchildren = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
reqs :: Seq SizeReq
reqs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s e. Bool -> WidgetNode s e -> SizeReq
mainReqSelector Bool
isHorizontal) Seq (WidgetNode s e)
vchildren
sumSizes :: (Double, Double, Double, Double)
-> SizeReq -> (Double, Double, Double, Double)
sumSizes (Double, Double, Double, Double)
accum SizeReq
req = (Double, Double, Double, Double)
newStep where
(Double
cFixed, Double
cFlex, Double
cFlexFac, Double
cExtraFac) = (Double, Double, Double, Double)
accum
newFixed :: Double
newFixed = Double
cFixed forall a. Num a => a -> a -> a
+ SizeReq -> Double
sizeReqFixed SizeReq
req
newFlex :: Double
newFlex = Double
cFlex forall a. Num a => a -> a -> a
+ SizeReq -> Double
sizeReqFlex SizeReq
req
newFlexFac :: Double
newFlexFac = Double
cFlexFac forall a. Num a => a -> a -> a
+ SizeReq -> Double
sizeReqFlex SizeReq
req forall a. Num a => a -> a -> a
* SizeReq -> Double
sizeReqFactor SizeReq
req
newExtraFac :: Double
newExtraFac = Double
cExtraFac forall a. Num a => a -> a -> a
+ SizeReq -> Double
sizeReqExtra SizeReq
req forall a. Num a => a -> a -> a
* SizeReq -> Double
sizeReqFactor SizeReq
req
newStep :: (Double, Double, Double, Double)
newStep = (Double
newFixed, Double
newFlex, Double
newFlexFac, Double
newExtraFac)
visibleSpacings :: Int
visibleSpacings = forall a. Ord a => a -> a -> a
max Int
0 (forall a. Seq a -> Int
Seq.length Seq (WidgetNode s e)
vchildren forall a. Num a => a -> a -> a
- Int
1)
totalSpacing :: Double
totalSpacing = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
visibleSpacings forall a. Num a => a -> a -> a
* Double
childSpacing
(Double
fixed, Double
flex, Double
flexFac, Double
extraFac) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Double, Double, Double, Double)
-> SizeReq -> (Double, Double, Double, Double)
sumSizes forall a. Default a => a
def Seq SizeReq
reqs
flexAvail :: Double
flexAvail = forall a. Ord a => a -> a -> a
min Double
flex (Double
mainSize forall a. Num a => a -> a -> a
- Double
fixed forall a. Num a => a -> a -> a
- Double
totalSpacing)
extraAvail :: Double
extraAvail = forall a. Ord a => a -> a -> a
max Double
0 (Double
mainSize forall a. Num a => a -> a -> a
- Double
fixed forall a. Num a => a -> a -> a
- Double
totalSpacing forall a. Num a => a -> a -> a
- Double
flexAvail)
flexCoeff :: Double
flexCoeff
| Double
flexAvail forall a. Ord a => a -> a -> Bool
< Double
flex Bool -> Bool -> Bool
&& Double
flexFac forall a. Ord a => a -> a -> Bool
> Double
0 = (Double
flexAvail forall a. Num a => a -> a -> a
- Double
flex) forall a. Fractional a => a -> a -> a
/ Double
flexFac
| Bool
otherwise = Double
0
extraCoeff :: Double
extraCoeff
| Double
extraAvail forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
extraFac forall a. Ord a => a -> a -> Bool
> Double
0 = Double
extraAvail forall a. Fractional a => a -> a -> a
/ Double
extraFac
| Bool
otherwise = Double
0
foldHelper :: (Seq Rect, Double, Int)
-> WidgetNode s e -> (Seq Rect, Double, Int)
foldHelper (Seq Rect
accum, Double
offset, Int
vIndex) WidgetNode s e
child = (Seq Rect
newAccum, Double
newOffset, Int
newVIndex) where
newRect :: Rect
newRect = forall s e.
Bool
-> Rect -> Double -> Double -> Double -> WidgetNode s e -> Rect
resizeChild Bool
isHorizontal Rect
contentArea Double
flexCoeff Double
extraCoeff Double
offset WidgetNode s e
child
newAccum :: Seq Rect
newAccum = Seq Rect
accum forall a. Seq a -> a -> Seq a
|> Rect
newRect
newOffset :: Double
newOffset = Double
offset forall a. Num a => a -> a -> a
+ Rect -> Double
rectSelector Rect
newRect forall a. Num a => a -> a -> a
+ Double
spacing
newVIndex :: Int
newVIndex = Int
vIndex forall a. Num a => a -> a -> a
+ if Bool
visible then Int
1 else Int
0
spacing :: Double
spacing = if Int
vIndex forall a. Ord a => a -> a -> Bool
< forall a. Seq a -> Int
Seq.length Seq (WidgetNode s e)
vchildren forall a. Num a => a -> a -> a
- Int
1 Bool -> Bool -> Bool
&& Bool
visible then Double
childSpacing else Double
0
visible :: Bool
visible = WidgetNodeInfo -> Bool
_wniVisible (forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo WidgetNode s e
child)
(Seq Rect
areas, Double
usedDim, Int
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {s} {e}.
(Seq Rect, Double, Int)
-> WidgetNode s e -> (Seq Rect, Double, Int)
foldHelper (forall a. Seq a
Seq.empty, Double
mainStart, Int
0) Seq (WidgetNode s e)
children
result :: (Seq Rect, Double)
result = (Seq Rect
areas, Double
usedDim forall a. Num a => a -> a -> a
- Double
mainStart)
resizeChild :: Bool -> Rect -> Factor -> Factor -> Double -> WidgetNode s e -> Rect
resizeChild :: forall s e.
Bool
-> Rect -> Double -> Double -> Double -> WidgetNode s e -> Rect
resizeChild Bool
horizontal Rect
contentArea Double
flexCoeff Double
extraCoeff Double
offset WidgetNode s e
child = Rect
result where
Rect Double
l Double
t Double
w Double
h = Rect
contentArea
emptyRect :: Rect
emptyRect = Double -> Double -> Double -> Double -> Rect
Rect Double
l Double
t Double
0 Double
0
SizeReq Double
fixed Double
flex Double
extra Double
factor = forall s e. Bool -> WidgetNode s e -> SizeReq
mainReqSelector Bool
horizontal WidgetNode s e
child
tempMainSize :: Double
tempMainSize = Double
fixed
forall a. Num a => a -> a -> a
+ (Double
1 forall a. Num a => a -> a -> a
+ Double
flexCoeff forall a. Num a => a -> a -> a
* Double
factor) forall a. Num a => a -> a -> a
* Double
flex
forall a. Num a => a -> a -> a
+ Double
extraCoeff forall a. Num a => a -> a -> a
* Double
factor forall a. Num a => a -> a -> a
* Double
extra
mainSize :: Double
mainSize = forall a. Ord a => a -> a -> a
max Double
0 Double
tempMainSize
hRect :: Rect
hRect = Double -> Double -> Double -> Double -> Rect
Rect Double
offset Double
t Double
mainSize Double
h
vRect :: Rect
vRect = Double -> Double -> Double -> Double -> Rect
Rect Double
l Double
offset Double
w Double
mainSize
result :: Rect
result
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (WidgetNodeInfo -> Bool
_wniVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) WidgetNode s e
child = Rect
emptyRect
| Bool
horizontal = Rect
hRect
| Bool
otherwise = Rect
vRect
mainReqSelector :: Bool -> WidgetNode s e -> SizeReq
mainReqSelector :: forall s e. Bool -> WidgetNode s e -> SizeReq
mainReqSelector Bool
isHorizontal
| Bool
isHorizontal = WidgetNodeInfo -> SizeReq
_wniSizeReqW forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo
| Bool
otherwise = WidgetNodeInfo -> SizeReq
_wniSizeReqH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo