{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Yi.Frontend.Pango.Layouts (
WidgetLike(..),
LayoutDisplay,
layoutDisplayNew,
layoutDisplaySet,
layoutDisplayOnDividerMove,
MiniwindowDisplay,
miniwindowDisplayNew,
miniwindowDisplaySet,
SimpleNotebook,
simpleNotebookNew,
simpleNotebookSet,
simpleNotebookOnSwitchPage,
update,
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad hiding (mapM, forM)
import Data.Foldable (toList)
import Data.IORef
import qualified Data.List.PointedList as PL
import qualified Data.Text as T
import Data.Traversable
import Graphics.UI.Gtk as Gtk hiding(Orientation, Layout)
import Prelude hiding (mapM)
import Yi.Layout(Orientation(..), RelativeSize, DividerPosition,
Layout(..), DividerRef)
class WidgetLike w where
baseWidget :: w -> Widget
newtype WeightedStack = WS Fixed
deriving(GObject -> WeightedStack
WeightedStack -> GObject
(WeightedStack -> GObject)
-> (GObject -> WeightedStack) -> GObjectClass WeightedStack
forall o. (o -> GObject) -> (GObject -> o) -> GObjectClass o
unsafeCastGObject :: GObject -> WeightedStack
$cunsafeCastGObject :: GObject -> WeightedStack
toGObject :: WeightedStack -> GObject
$ctoGObject :: WeightedStack -> GObject
GObjectClass, GObjectClass WeightedStack
GObjectClass WeightedStack -> ObjectClass WeightedStack
forall o. GObjectClass o -> ObjectClass o
ObjectClass, ObjectClass WeightedStack
ObjectClass WeightedStack -> WidgetClass WeightedStack
forall o. ObjectClass o -> WidgetClass o
WidgetClass,WidgetClass WeightedStack
WidgetClass WeightedStack -> ContainerClass WeightedStack
forall o. WidgetClass o -> ContainerClass o
ContainerClass)
type StackDescr = [(Widget, RelativeSize)]
weightedStackNew :: Orientation -> StackDescr -> IO WeightedStack
weightedStackNew :: Orientation -> StackDescr -> IO WeightedStack
weightedStackNew Orientation
o StackDescr
s = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((Widget, RelativeSize) -> Bool) -> StackDescr -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RelativeSize -> RelativeSize -> Bool
forall a. Ord a => a -> a -> Bool
<= RelativeSize
0) (RelativeSize -> Bool)
-> ((Widget, RelativeSize) -> RelativeSize)
-> (Widget, RelativeSize)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Widget, RelativeSize) -> RelativeSize
forall a b. (a, b) -> b
snd) StackDescr
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error
[Char]
"Yi.Frontend.Pango.WeightedStack.WeightedStack: all weights must be positive"
Fixed
l <- IO Fixed
fixedNew
Fixed -> [AttrOp Fixed] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set Fixed
l (((Widget, RelativeSize) -> AttrOp Fixed)
-> StackDescr -> [AttrOp Fixed]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WriteAttr Fixed Widget
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr Fixed Widget -> Widget -> AttrOp Fixed
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:=) (Widget -> AttrOp Fixed)
-> ((Widget, RelativeSize) -> Widget)
-> (Widget, RelativeSize)
-> AttrOp Fixed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Widget, RelativeSize) -> Widget
forall a b. (a, b) -> a
fst) StackDescr
s)
IO (ConnectId Fixed) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ConnectId Fixed) -> IO ()) -> IO (ConnectId Fixed) -> IO ()
forall a b. (a -> b) -> a -> b
$ Fixed
-> Signal Fixed (IO Requisition)
-> IO Requisition
-> IO (ConnectId Fixed)
forall object callback.
object
-> Signal object callback -> callback -> IO (ConnectId object)
Gtk.on Fixed
l Signal Fixed (IO Requisition)
forall self. WidgetClass self => Signal self (IO Requisition)
sizeRequest (Orientation -> StackDescr -> IO Requisition
doSizeRequest Orientation
o StackDescr
s)
IO (ConnectId Fixed) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ConnectId Fixed) -> IO ()) -> IO (ConnectId Fixed) -> IO ()
forall a b. (a -> b) -> a -> b
$ Fixed
-> Signal Fixed (Allocation -> IO ())
-> (Allocation -> IO ())
-> IO (ConnectId Fixed)
forall object callback.
object
-> Signal object callback -> callback -> IO (ConnectId object)
Gtk.on Fixed
l Signal Fixed (Allocation -> IO ())
forall self. WidgetClass self => Signal self (Allocation -> IO ())
sizeAllocate (Orientation -> StackDescr -> Allocation -> IO ()
relayout Orientation
o StackDescr
s)
WeightedStack -> IO WeightedStack
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixed -> WeightedStack
WS Fixed
l)
doSizeRequest :: Orientation -> StackDescr -> IO Requisition
doSizeRequest :: Orientation -> StackDescr -> IO Requisition
doSizeRequest Orientation
o StackDescr
s =
let
(Requisition -> RelativeSize
requestAlong, Requisition -> Int
requestAcross) =
case Orientation
o of
Orientation
Horizontal ->
(\(Requisition Int
w Int
_) -> Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w,
\(Requisition Int
_ Int
h) -> Int
h)
Orientation
Vertical ->
(\(Requisition Int
_ Int
h) -> Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h,
\(Requisition Int
w Int
_) -> Int
w)
totalWeight :: RelativeSize
totalWeight = [RelativeSize] -> RelativeSize
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([RelativeSize] -> RelativeSize)
-> (StackDescr -> [RelativeSize]) -> StackDescr -> RelativeSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Widget, RelativeSize) -> RelativeSize)
-> StackDescr -> [RelativeSize]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Widget, RelativeSize) -> RelativeSize
forall a b. (a, b) -> b
snd (StackDescr -> RelativeSize) -> StackDescr -> RelativeSize
forall a b. (a -> b) -> a -> b
$ StackDescr
s
reqsize :: (Requisition, RelativeSize) -> RelativeSize
reqsize (Requisition
request, RelativeSize
relSize) = Requisition -> RelativeSize
requestAlong Requisition
request RelativeSize -> RelativeSize -> RelativeSize
forall a. Fractional a => a -> a -> a
/ RelativeSize
relSize
sizeAlong :: t (Requisition, RelativeSize) -> RelativeSize
sizeAlong t (Requisition, RelativeSize)
widgetRequests =
RelativeSize
totalWeight RelativeSize -> RelativeSize -> RelativeSize
forall a. Num a => a -> a -> a
* (t RelativeSize -> RelativeSize
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (t RelativeSize -> RelativeSize)
-> (t (Requisition, RelativeSize) -> t RelativeSize)
-> t (Requisition, RelativeSize)
-> RelativeSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Requisition, RelativeSize) -> RelativeSize)
-> t (Requisition, RelativeSize) -> t RelativeSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Requisition, RelativeSize) -> RelativeSize
reqsize (t (Requisition, RelativeSize) -> RelativeSize)
-> t (Requisition, RelativeSize) -> RelativeSize
forall a b. (a -> b) -> a -> b
$ t (Requisition, RelativeSize)
widgetRequests)
sizeAcross :: t (Requisition, b) -> Int
sizeAcross t (Requisition, b)
widgetRequests =
t Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (t Int -> Int)
-> (t (Requisition, b) -> t Int) -> t (Requisition, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Requisition, b) -> Int) -> t (Requisition, b) -> t Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Requisition -> Int
requestAcross (Requisition -> Int)
-> ((Requisition, b) -> Requisition) -> (Requisition, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Requisition, b) -> Requisition
forall a b. (a, b) -> a
fst) (t (Requisition, b) -> Int) -> t (Requisition, b) -> Int
forall a b. (a -> b) -> a -> b
$ t (Requisition, b)
widgetRequests
mkRequisition :: t (Requisition, RelativeSize) -> Requisition
mkRequisition t (Requisition, RelativeSize)
wr =
case Orientation
o of
Orientation
Horizontal -> Int -> Int -> Requisition
Requisition (RelativeSize -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (RelativeSize -> Int) -> RelativeSize -> Int
forall a b. (a -> b) -> a -> b
$ t (Requisition, RelativeSize) -> RelativeSize
forall {t :: * -> *}.
(Foldable t, Functor t) =>
t (Requisition, RelativeSize) -> RelativeSize
sizeAlong t (Requisition, RelativeSize)
wr) (t (Requisition, RelativeSize) -> Int
forall {t :: * -> *} {b}.
(Foldable t, Functor t) =>
t (Requisition, b) -> Int
sizeAcross t (Requisition, RelativeSize)
wr)
Orientation
Vertical -> Int -> Int -> Requisition
Requisition (t (Requisition, RelativeSize) -> Int
forall {t :: * -> *} {b}.
(Foldable t, Functor t) =>
t (Requisition, b) -> Int
sizeAcross t (Requisition, RelativeSize)
wr) (RelativeSize -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (RelativeSize -> Int) -> RelativeSize -> Int
forall a b. (a -> b) -> a -> b
$ t (Requisition, RelativeSize) -> RelativeSize
forall {t :: * -> *}.
(Foldable t, Functor t) =>
t (Requisition, RelativeSize) -> RelativeSize
sizeAlong t (Requisition, RelativeSize)
wr)
swreq :: (self, t) -> IO (Requisition, t)
swreq (self
w, t
relSize) = (,t
relSize) (Requisition -> (Requisition, t))
-> IO Requisition -> IO (Requisition, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> self -> IO Requisition
forall self. WidgetClass self => self -> IO Requisition
widgetSizeRequest self
w
in
Requisition -> IO Requisition
boundRequisition (Requisition -> IO Requisition) -> IO Requisition -> IO Requisition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Requisition, RelativeSize)] -> Requisition
forall {t :: * -> *}.
(Foldable t, Functor t) =>
t (Requisition, RelativeSize) -> Requisition
mkRequisition ([(Requisition, RelativeSize)] -> Requisition)
-> IO [(Requisition, RelativeSize)] -> IO Requisition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Widget, RelativeSize) -> IO (Requisition, RelativeSize))
-> StackDescr -> IO [(Requisition, RelativeSize)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Widget, RelativeSize) -> IO (Requisition, RelativeSize)
forall {self} {t}.
WidgetClass self =>
(self, t) -> IO (Requisition, t)
swreq StackDescr
s
boundRequisition :: Requisition -> IO Requisition
boundRequisition :: Requisition -> IO Requisition
boundRequisition r :: Requisition
r@(Requisition Int
w Int
h) =
do
Maybe Screen
mscr <- IO (Maybe Screen)
screenGetDefault
case Maybe Screen
mscr of
Just Screen
scr -> Int -> Int -> Requisition
Requisition (Int -> Int -> Requisition) -> IO Int -> IO (Int -> Requisition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
w (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Screen -> IO Int
screenGetWidth Screen
scr)
IO (Int -> Requisition) -> IO Int -> IO Requisition
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
h (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Screen -> IO Int
screenGetHeight Screen
scr)
Maybe Screen
Nothing -> Requisition -> IO Requisition
forall (m :: * -> *) a. Monad m => a -> m a
return Requisition
r
relayout :: Orientation -> StackDescr -> Rectangle -> IO ()
relayout :: Orientation -> StackDescr -> Allocation -> IO ()
relayout Orientation
o StackDescr
s (Rectangle Int
x Int
y Int
width Int
height) =
let
totalWeight :: RelativeSize
totalWeight = [RelativeSize] -> RelativeSize
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([RelativeSize] -> RelativeSize)
-> (StackDescr -> [RelativeSize]) -> StackDescr -> RelativeSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Widget, RelativeSize) -> RelativeSize)
-> StackDescr -> [RelativeSize]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Widget, RelativeSize) -> RelativeSize
forall a b. (a, b) -> b
snd (StackDescr -> RelativeSize) -> StackDescr -> RelativeSize
forall a b. (a -> b) -> a -> b
$ StackDescr
s
totalSpace :: RelativeSize
totalSpace = Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> RelativeSize) -> Int -> RelativeSize
forall a b. (a -> b) -> a -> b
$
case Orientation
o of
Orientation
Horizontal -> Int
width
Orientation
Vertical -> Int
height
wtMult :: RelativeSize
wtMult = RelativeSize
totalSpace RelativeSize -> RelativeSize -> RelativeSize
forall a. Fractional a => a -> a -> a
/ RelativeSize
totalWeight
calcPosition :: RelativeSize
-> (c, RelativeSize)
-> (RelativeSize, (RelativeSize, RelativeSize, c))
calcPosition RelativeSize
pos (c
widget, RelativeSize
wt) = (RelativeSize
pos RelativeSize -> RelativeSize -> RelativeSize
forall a. Num a => a -> a -> a
+ RelativeSize
wt RelativeSize -> RelativeSize -> RelativeSize
forall a. Num a => a -> a -> a
* RelativeSize
wtMult,
(RelativeSize
pos, RelativeSize
wt RelativeSize -> RelativeSize -> RelativeSize
forall a. Num a => a -> a -> a
* RelativeSize
wtMult, c
widget))
widgetToRectangle :: (a, a, b) -> (Allocation, b)
widgetToRectangle (a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round -> Int
pos, a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round -> Int
size, b
widget) =
case Orientation
o of
Orientation
Horizontal -> (Int -> Int -> Int -> Int -> Allocation
Rectangle Int
pos Int
y Int
size Int
height, b
widget)
Orientation
Vertical -> (Int -> Int -> Int -> Int -> Allocation
Rectangle Int
x Int
pos Int
width Int
size, b
widget)
startPosition :: RelativeSize
startPosition = Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> RelativeSize) -> Int -> RelativeSize
forall a b. (a -> b) -> a -> b
$
case Orientation
o of
Orientation
Horizontal -> Int
x
Orientation
Vertical -> Int
y
widgetPositions :: [(Allocation, Widget)]
widgetPositions =
((RelativeSize, RelativeSize, Widget) -> (Allocation, Widget))
-> [(RelativeSize, RelativeSize, Widget)] -> [(Allocation, Widget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RelativeSize, RelativeSize, Widget) -> (Allocation, Widget)
forall {a} {a} {b}.
(RealFrac a, RealFrac a) =>
(a, a, b) -> (Allocation, b)
widgetToRectangle ((RelativeSize, [(RelativeSize, RelativeSize, Widget)])
-> [(RelativeSize, RelativeSize, Widget)]
forall a b. (a, b) -> b
snd ((RelativeSize
-> (Widget, RelativeSize)
-> (RelativeSize, (RelativeSize, RelativeSize, Widget)))
-> RelativeSize
-> StackDescr
-> (RelativeSize, [(RelativeSize, RelativeSize, Widget)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL RelativeSize
-> (Widget, RelativeSize)
-> (RelativeSize, (RelativeSize, RelativeSize, Widget))
forall {c}.
RelativeSize
-> (c, RelativeSize)
-> (RelativeSize, (RelativeSize, RelativeSize, c))
calcPosition RelativeSize
startPosition StackDescr
s))
in [(Allocation, Widget)] -> ((Allocation, Widget) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Allocation, Widget)]
widgetPositions (((Allocation, Widget) -> IO ()) -> IO ())
-> ((Allocation, Widget) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Allocation
rect, Widget
widget) -> Widget -> Allocation -> IO ()
forall self. WidgetClass self => self -> Allocation -> IO ()
widgetSizeAllocate Widget
widget Allocation
rect
newtype SlidingPair = SP Paned
deriving(GObject -> SlidingPair
SlidingPair -> GObject
(SlidingPair -> GObject)
-> (GObject -> SlidingPair) -> GObjectClass SlidingPair
forall o. (o -> GObject) -> (GObject -> o) -> GObjectClass o
unsafeCastGObject :: GObject -> SlidingPair
$cunsafeCastGObject :: GObject -> SlidingPair
toGObject :: SlidingPair -> GObject
$ctoGObject :: SlidingPair -> GObject
GObjectClass, GObjectClass SlidingPair
GObjectClass SlidingPair -> ObjectClass SlidingPair
forall o. GObjectClass o -> ObjectClass o
ObjectClass, ObjectClass SlidingPair
ObjectClass SlidingPair -> WidgetClass SlidingPair
forall o. ObjectClass o -> WidgetClass o
WidgetClass, WidgetClass SlidingPair
WidgetClass SlidingPair -> ContainerClass SlidingPair
forall o. WidgetClass o -> ContainerClass o
ContainerClass)
slidingPairNew :: (WidgetClass w1, WidgetClass w2) => Orientation -> w1 -> w2
-> DividerPosition
-> (DividerPosition -> IO ())
-> IO SlidingPair
slidingPairNew :: forall w1 w2.
(WidgetClass w1, WidgetClass w2) =>
Orientation
-> w1
-> w2
-> RelativeSize
-> (RelativeSize -> IO ())
-> IO SlidingPair
slidingPairNew Orientation
o w1
w1 w2
w2 RelativeSize
pos RelativeSize -> IO ()
handleNewPos = do
Paned
p <-
case Orientation
o of
Orientation
Horizontal -> HPaned -> Paned
forall o. PanedClass o => o -> Paned
toPaned (HPaned -> Paned) -> IO HPaned -> IO Paned
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO HPaned
hPanedNew
Orientation
Vertical -> VPaned -> Paned
forall o. PanedClass o => o -> Paned
toPaned (VPaned -> Paned) -> IO VPaned -> IO Paned
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO VPaned
vPanedNew
Paned -> w1 -> Bool -> Bool -> IO ()
forall self child.
(PanedClass self, WidgetClass child) =>
self -> child -> Bool -> Bool -> IO ()
panedPack1 Paned
p w1
w1 Bool
True Bool
True
Paned -> w2 -> Bool -> Bool -> IO ()
forall self child.
(PanedClass self, WidgetClass child) =>
self -> child -> Bool -> Bool -> IO ()
panedPack2 Paned
p w2
w2 Bool
True Bool
True
IORef RelativeSize
posRef <- RelativeSize -> IO (IORef RelativeSize)
forall a. a -> IO (IORef a)
newIORef RelativeSize
pos
IORef Int
sizeRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IO (ConnectId Paned) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ConnectId Paned) -> IO ()) -> IO (ConnectId Paned) -> IO ()
forall a b. (a -> b) -> a -> b
$ Paned
-> Signal Paned (Allocation -> IO ())
-> (Allocation -> IO ())
-> IO (ConnectId Paned)
forall object callback.
object
-> Signal object callback -> callback -> IO (ConnectId object)
Gtk.on Paned
p Signal Paned (Allocation -> IO ())
forall self. WidgetClass self => Signal self (Allocation -> IO ())
sizeAllocate ((Allocation -> IO ()) -> IO (ConnectId Paned))
-> (Allocation -> IO ()) -> IO (ConnectId Paned)
forall a b. (a -> b) -> a -> b
$ \(Rectangle Int
_ Int
_ Int
w Int
h) ->
do
Int
oldSz <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
sizeRef
RelativeSize
oldPos <- IORef RelativeSize -> IO RelativeSize
forall a. IORef a -> IO a
readIORef IORef RelativeSize
posRef
let sz :: Int
sz = case Orientation
o of
Orientation
Horizontal -> Int
w
Orientation
Vertical -> Int
h
IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
sizeRef Int
sz
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if Int
sz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
oldSz
then do
Int
sliderPos <- Paned -> ReadWriteAttr Paned Int Int -> IO Int
forall o a b. o -> ReadWriteAttr o a b -> IO a
get Paned
p ReadWriteAttr Paned Int Int
forall self. PanedClass self => Attr self Int
panedPosition
let newPos :: RelativeSize
newPos = Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sliderPos RelativeSize -> RelativeSize -> RelativeSize
forall a. Fractional a => a -> a -> a
/ Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
IORef RelativeSize -> RelativeSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef RelativeSize
posRef RelativeSize
newPos
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelativeSize
oldPos RelativeSize -> RelativeSize -> Bool
forall a. Eq a => a -> a -> Bool
/= RelativeSize
newPos) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RelativeSize -> IO ()
handleNewPos RelativeSize
newPos
else
Paned -> [AttrOp Paned] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set Paned
p [ ReadWriteAttr Paned Int Int
forall self. PanedClass self => Attr self Int
panedPosition ReadWriteAttr Paned Int Int -> Int -> AttrOp Paned
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= RelativeSize -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (RelativeSize
oldPos RelativeSize -> RelativeSize -> RelativeSize
forall a. Num a => a -> a -> a
* Int -> RelativeSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) ]
SlidingPair -> IO SlidingPair
forall (m :: * -> *) a. Monad m => a -> m a
return (Paned -> SlidingPair
SP Paned
p)
data LayoutDisplay
= LD {
LayoutDisplay -> Bin
mainWidget :: Bin,
LayoutDisplay -> IORef (Maybe LayoutImpl)
implWidget :: IORef (Maybe LayoutImpl),
LayoutDisplay -> IORef [Int -> RelativeSize -> IO ()]
dividerCallbacks :: IORef [DividerRef -> DividerPosition -> IO ()]
}
data LayoutImpl
= SingleWindowI {
LayoutImpl -> Widget
singleWidget :: Widget
}
| StackI {
LayoutImpl -> Orientation
orientationI :: Orientation,
LayoutImpl -> [(LayoutImpl, RelativeSize)]
winsI :: [(LayoutImpl, RelativeSize)],
LayoutImpl -> WeightedStack
stackWidget :: WeightedStack
}
| PairI {
orientationI :: Orientation,
LayoutImpl -> LayoutImpl
pairFstI :: LayoutImpl,
LayoutImpl -> LayoutImpl
pairSndI :: LayoutImpl,
LayoutImpl -> Int
divRefI :: DividerRef,
LayoutImpl -> SlidingPair
pairWidget :: SlidingPair
}
layoutDisplayNew :: IO LayoutDisplay
layoutDisplayNew :: IO LayoutDisplay
layoutDisplayNew = do
IORef [Int -> RelativeSize -> IO ()]
cbRef <- [Int -> RelativeSize -> IO ()]
-> IO (IORef [Int -> RelativeSize -> IO ()])
forall a. a -> IO (IORef a)
newIORef []
IORef (Maybe LayoutImpl)
implRef <- Maybe LayoutImpl -> IO (IORef (Maybe LayoutImpl))
forall a. a -> IO (IORef a)
newIORef Maybe LayoutImpl
forall a. Maybe a
Nothing
Bin
box <- Alignment -> Bin
forall o. BinClass o => o -> Bin
toBin (Alignment -> Bin) -> IO Alignment -> IO Bin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Float -> Float -> Float -> Float -> IO Alignment
alignmentNew Float
0 Float
0 Float
1 Float
1
LayoutDisplay -> IO LayoutDisplay
forall (m :: * -> *) a. Monad m => a -> m a
return (Bin
-> IORef (Maybe LayoutImpl)
-> IORef [Int -> RelativeSize -> IO ()]
-> LayoutDisplay
LD Bin
box IORef (Maybe LayoutImpl)
implRef IORef [Int -> RelativeSize -> IO ()]
cbRef)
layoutDisplayOnDividerMove :: LayoutDisplay
-> (DividerRef -> DividerPosition -> IO ())
-> IO ()
layoutDisplayOnDividerMove :: LayoutDisplay -> (Int -> RelativeSize -> IO ()) -> IO ()
layoutDisplayOnDividerMove LayoutDisplay
ld Int -> RelativeSize -> IO ()
cb = IORef [Int -> RelativeSize -> IO ()]
-> ([Int -> RelativeSize -> IO ()]
-> [Int -> RelativeSize -> IO ()])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (LayoutDisplay -> IORef [Int -> RelativeSize -> IO ()]
dividerCallbacks LayoutDisplay
ld) (Int -> RelativeSize -> IO ()
cb(Int -> RelativeSize -> IO ())
-> [Int -> RelativeSize -> IO ()] -> [Int -> RelativeSize -> IO ()]
forall a. a -> [a] -> [a]
:)
layoutDisplaySet :: LayoutDisplay -> Layout Widget -> IO ()
layoutDisplaySet :: LayoutDisplay -> Layout Widget -> IO ()
layoutDisplaySet LayoutDisplay
ld Layout Widget
lyt = do
Maybe LayoutImpl
mimpl <- IORef (Maybe LayoutImpl) -> IO (Maybe LayoutImpl)
forall a. IORef a -> IO a
readIORef (LayoutDisplay -> IORef (Maybe LayoutImpl)
implWidget LayoutDisplay
ld)
let applyLayout :: IO ()
applyLayout = do
LayoutImpl
impl' <- (Int -> RelativeSize -> IO ()) -> Layout Widget -> IO LayoutImpl
buildImpl (IORef [Int -> RelativeSize -> IO ()]
-> Int -> RelativeSize -> IO ()
runCb (IORef [Int -> RelativeSize -> IO ()]
-> Int -> RelativeSize -> IO ())
-> IORef [Int -> RelativeSize -> IO ()]
-> Int
-> RelativeSize
-> IO ()
forall a b. (a -> b) -> a -> b
$ LayoutDisplay -> IORef [Int -> RelativeSize -> IO ()]
dividerCallbacks LayoutDisplay
ld) Layout Widget
lyt
Widget -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetShowAll (LayoutImpl -> Widget
outerWidget LayoutImpl
impl')
Bin -> [AttrOp Bin] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set (LayoutDisplay -> Bin
mainWidget LayoutDisplay
ld) [WriteAttr Bin Widget
forall self widget.
(ContainerClass self, WidgetClass widget) =>
WriteAttr self widget
containerChild WriteAttr Bin Widget -> Widget -> AttrOp Bin
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= LayoutImpl -> Widget
outerWidget LayoutImpl
impl']
IORef (Maybe LayoutImpl) -> Maybe LayoutImpl -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (LayoutDisplay -> IORef (Maybe LayoutImpl)
implWidget LayoutDisplay
ld) (LayoutImpl -> Maybe LayoutImpl
forall a. a -> Maybe a
Just LayoutImpl
impl')
case Maybe LayoutImpl
mimpl of
Maybe LayoutImpl
Nothing -> IO ()
applyLayout
Just LayoutImpl
impl -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LayoutImpl -> Layout Widget -> Bool
sameLayout LayoutImpl
impl Layout Widget
lyt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Container -> LayoutImpl -> IO ()
unattachWidgets (Bin -> Container
forall o. ContainerClass o => o -> Container
toContainer (Bin -> Container) -> Bin -> Container
forall a b. (a -> b) -> a -> b
$ LayoutDisplay -> Bin
mainWidget LayoutDisplay
ld) LayoutImpl
impl
IO ()
applyLayout
runCb :: IORef [DividerRef -> DividerPosition -> IO ()]
-> DividerRef -> DividerPosition -> IO ()
runCb :: IORef [Int -> RelativeSize -> IO ()]
-> Int -> RelativeSize -> IO ()
runCb IORef [Int -> RelativeSize -> IO ()]
cbRef Int
dRef RelativeSize
dPos = IORef [Int -> RelativeSize -> IO ()]
-> IO [Int -> RelativeSize -> IO ()]
forall a. IORef a -> IO a
readIORef IORef [Int -> RelativeSize -> IO ()]
cbRef IO [Int -> RelativeSize -> IO ()]
-> ([Int -> RelativeSize -> IO ()] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Int -> RelativeSize -> IO ()) -> IO ())
-> [Int -> RelativeSize -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int -> RelativeSize -> IO ()
cb -> Int -> RelativeSize -> IO ()
cb Int
dRef RelativeSize
dPos)
buildImpl :: (DividerRef -> DividerPosition -> IO ())
-> Layout Widget -> IO LayoutImpl
buildImpl :: (Int -> RelativeSize -> IO ()) -> Layout Widget -> IO LayoutImpl
buildImpl Int -> RelativeSize -> IO ()
cb = Layout Widget -> IO LayoutImpl
go
where
go :: Layout Widget -> IO LayoutImpl
go (SingleWindow Widget
w) = LayoutImpl -> IO LayoutImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget -> LayoutImpl
SingleWindowI Widget
w)
go (s :: Layout Widget
s@Stack{}) = do
[(LayoutImpl, RelativeSize)]
impls <- [(Layout Widget, RelativeSize)]
-> ((Layout Widget, RelativeSize) -> IO (LayoutImpl, RelativeSize))
-> IO [(LayoutImpl, RelativeSize)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Layout Widget -> [(Layout Widget, RelativeSize)]
forall a. Layout a -> [(Layout a, RelativeSize)]
wins Layout Widget
s) (((Layout Widget, RelativeSize) -> IO (LayoutImpl, RelativeSize))
-> IO [(LayoutImpl, RelativeSize)])
-> ((Layout Widget, RelativeSize) -> IO (LayoutImpl, RelativeSize))
-> IO [(LayoutImpl, RelativeSize)]
forall a b. (a -> b) -> a -> b
$ \(Layout Widget
lyt,RelativeSize
relSize) -> (,RelativeSize
relSize) (LayoutImpl -> (LayoutImpl, RelativeSize))
-> IO LayoutImpl -> IO (LayoutImpl, RelativeSize)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Layout Widget -> IO LayoutImpl
go Layout Widget
lyt
WeightedStack
ws <- Orientation -> StackDescr -> IO WeightedStack
weightedStackNew (Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
s) ((LayoutImpl -> Widget)
-> (LayoutImpl, RelativeSize) -> (Widget, RelativeSize)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first LayoutImpl -> Widget
outerWidget ((LayoutImpl, RelativeSize) -> (Widget, RelativeSize))
-> [(LayoutImpl, RelativeSize)] -> StackDescr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LayoutImpl, RelativeSize)]
impls)
LayoutImpl -> IO LayoutImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (Orientation
-> [(LayoutImpl, RelativeSize)] -> WeightedStack -> LayoutImpl
StackI (Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
s) [(LayoutImpl, RelativeSize)]
impls WeightedStack
ws)
go (p :: Layout Widget
p@Pair{}) = do
LayoutImpl
w1 <- Layout Widget -> IO LayoutImpl
go (Layout Widget -> Layout Widget
forall a. Layout a -> Layout a
pairFst Layout Widget
p)
LayoutImpl
w2 <- Layout Widget -> IO LayoutImpl
go (Layout Widget -> Layout Widget
forall a. Layout a -> Layout a
pairSnd Layout Widget
p)
SlidingPair
sp <- Orientation
-> Widget
-> Widget
-> RelativeSize
-> (RelativeSize -> IO ())
-> IO SlidingPair
forall w1 w2.
(WidgetClass w1, WidgetClass w2) =>
Orientation
-> w1
-> w2
-> RelativeSize
-> (RelativeSize -> IO ())
-> IO SlidingPair
slidingPairNew (Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
p) (LayoutImpl -> Widget
outerWidget LayoutImpl
w1)
(LayoutImpl -> Widget
outerWidget LayoutImpl
w2) (Layout Widget -> RelativeSize
forall a. Layout a -> RelativeSize
divPos Layout Widget
p) (Int -> RelativeSize -> IO ()
cb (Int -> RelativeSize -> IO ()) -> Int -> RelativeSize -> IO ()
forall a b. (a -> b) -> a -> b
$ Layout Widget -> Int
forall a. Layout a -> Int
divRef Layout Widget
p)
LayoutImpl -> IO LayoutImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (LayoutImpl -> IO LayoutImpl) -> LayoutImpl -> IO LayoutImpl
forall a b. (a -> b) -> a -> b
$ Orientation
-> LayoutImpl -> LayoutImpl -> Int -> SlidingPair -> LayoutImpl
PairI (Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
p) LayoutImpl
w1 LayoutImpl
w2 (Layout Widget -> Int
forall a. Layout a -> Int
divRef Layout Widget
p) SlidingPair
sp
sameLayout :: LayoutImpl -> Layout Widget -> Bool
sameLayout :: LayoutImpl -> Layout Widget -> Bool
sameLayout (SingleWindowI Widget
w) (SingleWindow Widget
w') = Widget
w Widget -> Widget -> Bool
forall a. Eq a => a -> a -> Bool
== Widget
w'
sameLayout (s :: LayoutImpl
s@StackI{}) (s' :: Layout Widget
s'@Stack{}) =
LayoutImpl -> Orientation
orientationI LayoutImpl
s Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
s'
Bool -> Bool -> Bool
&& [(LayoutImpl, RelativeSize)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (LayoutImpl -> [(LayoutImpl, RelativeSize)]
winsI LayoutImpl
s) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Layout Widget, RelativeSize)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Layout Widget -> [(Layout Widget, RelativeSize)]
forall a. Layout a -> [(Layout a, RelativeSize)]
wins Layout Widget
s')
Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((LayoutImpl, RelativeSize)
-> (Layout Widget, RelativeSize) -> Bool)
-> [(LayoutImpl, RelativeSize)]
-> [(Layout Widget, RelativeSize)]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(LayoutImpl
impl, RelativeSize
relSize) (Layout Widget
layout, RelativeSize
relSize') ->
RelativeSize
relSize RelativeSize -> RelativeSize -> Bool
forall a. Eq a => a -> a -> Bool
== RelativeSize
relSize' Bool -> Bool -> Bool
&& LayoutImpl -> Layout Widget -> Bool
sameLayout LayoutImpl
impl Layout Widget
layout)
(LayoutImpl -> [(LayoutImpl, RelativeSize)]
winsI LayoutImpl
s) (Layout Widget -> [(Layout Widget, RelativeSize)]
forall a. Layout a -> [(Layout a, RelativeSize)]
wins Layout Widget
s'))
sameLayout (p :: LayoutImpl
p@PairI{}) (p' :: Layout Widget
p'@Pair{}) =
LayoutImpl -> Orientation
orientationI LayoutImpl
p Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Layout Widget -> Orientation
forall a. Layout a -> Orientation
orientation Layout Widget
p'
Bool -> Bool -> Bool
&& LayoutImpl -> Int
divRefI LayoutImpl
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Layout Widget -> Int
forall a. Layout a -> Int
divRef Layout Widget
p'
Bool -> Bool -> Bool
&& LayoutImpl -> Layout Widget -> Bool
sameLayout (LayoutImpl -> LayoutImpl
pairFstI LayoutImpl
p) (Layout Widget -> Layout Widget
forall a. Layout a -> Layout a
pairFst Layout Widget
p')
Bool -> Bool -> Bool
&& LayoutImpl -> Layout Widget -> Bool
sameLayout (LayoutImpl -> LayoutImpl
pairSndI LayoutImpl
p) (Layout Widget -> Layout Widget
forall a. Layout a -> Layout a
pairSnd Layout Widget
p')
sameLayout LayoutImpl
_ Layout Widget
_ = Bool
False
unattachWidgets :: Container -> LayoutImpl -> IO ()
unattachWidgets :: Container -> LayoutImpl -> IO ()
unattachWidgets Container
parent (SingleWindowI Widget
w) = Container -> Widget -> IO ()
forall self widget.
(ContainerClass self, WidgetClass widget) =>
self -> widget -> IO ()
containerRemove Container
parent Widget
w
unattachWidgets Container
parent s :: LayoutImpl
s@StackI{} = do
Container -> WeightedStack -> IO ()
forall self widget.
(ContainerClass self, WidgetClass widget) =>
self -> widget -> IO ()
containerRemove Container
parent (LayoutImpl -> WeightedStack
stackWidget LayoutImpl
s)
((LayoutImpl, RelativeSize) -> IO ())
-> [(LayoutImpl, RelativeSize)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Container -> LayoutImpl -> IO ()
unattachWidgets (WeightedStack -> Container
forall o. ContainerClass o => o -> Container
toContainer (WeightedStack -> Container) -> WeightedStack -> Container
forall a b. (a -> b) -> a -> b
$ LayoutImpl -> WeightedStack
stackWidget LayoutImpl
s) (LayoutImpl -> IO ())
-> ((LayoutImpl, RelativeSize) -> LayoutImpl)
-> (LayoutImpl, RelativeSize)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LayoutImpl, RelativeSize) -> LayoutImpl
forall a b. (a, b) -> a
fst) (LayoutImpl -> [(LayoutImpl, RelativeSize)]
winsI LayoutImpl
s)
unattachWidgets Container
parent p :: LayoutImpl
p@PairI{} = do
Container -> SlidingPair -> IO ()
forall self widget.
(ContainerClass self, WidgetClass widget) =>
self -> widget -> IO ()
containerRemove Container
parent (LayoutImpl -> SlidingPair
pairWidget LayoutImpl
p)
(LayoutImpl -> IO ()) -> [LayoutImpl] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Container -> LayoutImpl -> IO ()
unattachWidgets (SlidingPair -> Container
forall o. ContainerClass o => o -> Container
toContainer (SlidingPair -> Container) -> SlidingPair -> Container
forall a b. (a -> b) -> a -> b
$ LayoutImpl -> SlidingPair
pairWidget LayoutImpl
p)) [LayoutImpl -> LayoutImpl
pairFstI LayoutImpl
p, LayoutImpl -> LayoutImpl
pairSndI LayoutImpl
p]
outerWidget :: LayoutImpl -> Widget
outerWidget :: LayoutImpl -> Widget
outerWidget s :: LayoutImpl
s@SingleWindowI{} = LayoutImpl -> Widget
singleWidget LayoutImpl
s
outerWidget s :: LayoutImpl
s@StackI{} = WeightedStack -> Widget
forall o. WidgetClass o => o -> Widget
toWidget (WeightedStack -> Widget)
-> (LayoutImpl -> WeightedStack) -> LayoutImpl -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutImpl -> WeightedStack
stackWidget (LayoutImpl -> Widget) -> LayoutImpl -> Widget
forall a b. (a -> b) -> a -> b
$ LayoutImpl
s
outerWidget p :: LayoutImpl
p@PairI{} = SlidingPair -> Widget
forall o. WidgetClass o => o -> Widget
toWidget (SlidingPair -> Widget)
-> (LayoutImpl -> SlidingPair) -> LayoutImpl -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutImpl -> SlidingPair
pairWidget (LayoutImpl -> Widget) -> LayoutImpl -> Widget
forall a b. (a -> b) -> a -> b
$ LayoutImpl
p
instance WidgetLike LayoutDisplay where
baseWidget :: LayoutDisplay -> Widget
baseWidget = Bin -> Widget
forall o. WidgetClass o => o -> Widget
toWidget (Bin -> Widget)
-> (LayoutDisplay -> Bin) -> LayoutDisplay -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutDisplay -> Bin
mainWidget
data MiniwindowDisplay
= MD
{ MiniwindowDisplay -> VBox
mwdMainWidget :: VBox,
MiniwindowDisplay -> IORef [Widget]
mwdWidgets :: IORef [Widget]
}
miniwindowDisplayNew :: IO MiniwindowDisplay
miniwindowDisplayNew :: IO MiniwindowDisplay
miniwindowDisplayNew = do
VBox
vb <- Bool -> Int -> IO VBox
vBoxNew Bool
False Int
1
IORef [Widget]
wsRef <- [Widget] -> IO (IORef [Widget])
forall a. a -> IO (IORef a)
newIORef []
MiniwindowDisplay -> IO MiniwindowDisplay
forall (m :: * -> *) a. Monad m => a -> m a
return (VBox -> IORef [Widget] -> MiniwindowDisplay
MD VBox
vb IORef [Widget]
wsRef)
instance WidgetLike MiniwindowDisplay where
baseWidget :: MiniwindowDisplay -> Widget
baseWidget = VBox -> Widget
forall o. WidgetClass o => o -> Widget
toWidget (VBox -> Widget)
-> (MiniwindowDisplay -> VBox) -> MiniwindowDisplay -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiniwindowDisplay -> VBox
mwdMainWidget
miniwindowDisplaySet :: MiniwindowDisplay -> [Widget] -> IO ()
miniwindowDisplaySet :: MiniwindowDisplay -> [Widget] -> IO ()
miniwindowDisplaySet MiniwindowDisplay
mwd [Widget]
ws = do
[Widget]
curWs <- IORef [Widget] -> IO [Widget]
forall a. IORef a -> IO a
readIORef (MiniwindowDisplay -> IORef [Widget]
mwdWidgets MiniwindowDisplay
mwd)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Widget]
ws [Widget] -> [Widget] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Widget]
curWs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Widget] -> (Widget -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Widget]
curWs ((Widget -> IO ()) -> IO ()) -> (Widget -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ VBox -> Widget -> IO ()
forall self widget.
(ContainerClass self, WidgetClass widget) =>
self -> widget -> IO ()
containerRemove (MiniwindowDisplay -> VBox
mwdMainWidget MiniwindowDisplay
mwd)
[Widget] -> (Widget -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Widget]
ws ((Widget -> IO ()) -> IO ()) -> (Widget -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Widget
w -> VBox -> Widget -> Packing -> Int -> IO ()
forall self child.
(BoxClass self, WidgetClass child) =>
self -> child -> Packing -> Int -> IO ()
boxPackEnd (MiniwindowDisplay -> VBox
mwdMainWidget MiniwindowDisplay
mwd) Widget
w Packing
PackNatural Int
0
VBox -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetShowAll (VBox -> IO ()) -> VBox -> IO ()
forall a b. (a -> b) -> a -> b
$ MiniwindowDisplay -> VBox
mwdMainWidget MiniwindowDisplay
mwd
IORef [Widget] -> [Widget] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (MiniwindowDisplay -> IORef [Widget]
mwdWidgets MiniwindowDisplay
mwd) [Widget]
ws
data SimpleNotebook
= SN
{ SimpleNotebook -> Notebook
snMainWidget :: Notebook,
SimpleNotebook -> IORef (Maybe (PointedList (Widget, Text)))
snTabs :: IORef (Maybe (PL.PointedList (Widget, T.Text)))
}
instance WidgetLike SimpleNotebook where
baseWidget :: SimpleNotebook -> Widget
baseWidget = Notebook -> Widget
forall o. WidgetClass o => o -> Widget
toWidget (Notebook -> Widget)
-> (SimpleNotebook -> Notebook) -> SimpleNotebook -> Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleNotebook -> Notebook
snMainWidget
simpleNotebookNew :: IO SimpleNotebook
simpleNotebookNew :: IO SimpleNotebook
simpleNotebookNew = do
Notebook
nb <- IO Notebook
notebookNew
IORef (Maybe (PointedList (Widget, Text)))
ts <- Maybe (PointedList (Widget, Text))
-> IO (IORef (Maybe (PointedList (Widget, Text))))
forall a. a -> IO (IORef a)
newIORef Maybe (PointedList (Widget, Text))
forall a. Maybe a
Nothing
SimpleNotebook -> IO SimpleNotebook
forall (m :: * -> *) a. Monad m => a -> m a
return (Notebook
-> IORef (Maybe (PointedList (Widget, Text))) -> SimpleNotebook
SN Notebook
nb IORef (Maybe (PointedList (Widget, Text)))
ts)
simpleNotebookSet :: SimpleNotebook -> PL.PointedList (Widget, T.Text) -> IO ()
simpleNotebookSet :: SimpleNotebook -> PointedList (Widget, Text) -> IO ()
simpleNotebookSet SimpleNotebook
sn PointedList (Widget, Text)
ts = do
Maybe (PointedList (Widget, Text))
curTs <- IORef (Maybe (PointedList (Widget, Text)))
-> IO (Maybe (PointedList (Widget, Text)))
forall a. IORef a -> IO a
readIORef (SimpleNotebook -> IORef (Maybe (PointedList (Widget, Text)))
snTabs SimpleNotebook
sn)
let nb :: Notebook
nb = SimpleNotebook -> Notebook
snMainWidget SimpleNotebook
sn
tsList :: [(Widget, Text)]
tsList = PointedList (Widget, Text) -> [(Widget, Text)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList PointedList (Widget, Text)
ts
curTsList :: [(Widget, Text)]
curTsList = [(Widget, Text)]
-> (PointedList (Widget, Text) -> [(Widget, Text)])
-> Maybe (PointedList (Widget, Text))
-> [(Widget, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] PointedList (Widget, Text) -> [(Widget, Text)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (PointedList (Widget, Text))
curTs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (PointedList (Widget, Text))
curTs Maybe (PointedList (Widget, Text))
-> Maybe (PointedList (Widget, Text)) -> Bool
forall a. Eq a => a -> a -> Bool
/= PointedList (Widget, Text) -> Maybe (PointedList (Widget, Text))
forall a. a -> Maybe a
Just PointedList (Widget, Text)
ts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((Widget, Text) -> Widget) -> [(Widget, Text)] -> [Widget]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Widget, Text) -> Widget
forall a b. (a, b) -> a
fst [(Widget, Text)]
curTsList [Widget] -> [Widget] -> Bool
forall a. Eq a => a -> a -> Bool
/= ((Widget, Text) -> Widget) -> [(Widget, Text)] -> [Widget]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Widget, Text) -> Widget
forall a b. (a, b) -> a
fst [(Widget, Text)]
tsList) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[(Widget, Text)] -> ((Widget, Text) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Widget, Text)]
curTsList (((Widget, Text) -> IO ()) -> IO ())
-> ((Widget, Text) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Widget, Text) -> IO ()
forall a b. a -> b -> a
const (Notebook -> Int -> IO ()
forall self. NotebookClass self => self -> Int -> IO ()
notebookRemovePage Notebook
nb (-Int
1))
[(Widget, Text)] -> ((Widget, Text) -> IO Int) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Widget, Text)]
tsList (((Widget, Text) -> IO Int) -> IO ())
-> ((Widget, Text) -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Widget -> Text -> IO Int) -> (Widget, Text) -> IO Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Notebook -> Widget -> Text -> IO Int
forall self child string.
(NotebookClass self, WidgetClass child, GlibString string) =>
self -> child -> string -> IO Int
notebookAppendPage Notebook
nb)
[(Widget, Text)] -> ((Widget, Text) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Widget, Text)]
tsList (((Widget, Text) -> IO ()) -> IO ())
-> ((Widget, Text) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Widget
w,Text
s) -> Notebook -> ReadWriteAttr Notebook Text Text -> Text -> IO ()
forall a o. Eq a => o -> ReadWriteAttr o a a -> a -> IO ()
update Notebook
nb (Widget -> ReadWriteAttr Notebook Text Text
forall self child string.
(NotebookClass self, WidgetClass child, GlibString string) =>
child -> Attr self string
notebookChildTabLabel Widget
w) Text
s
Maybe Int
p <- Notebook -> Widget -> IO (Maybe Int)
forall self w.
(NotebookClass self, WidgetClass w) =>
self -> w -> IO (Maybe Int)
notebookPageNum Notebook
nb ((Widget, Text) -> Widget
forall a b. (a, b) -> a
fst ((Widget, Text) -> Widget) -> (Widget, Text) -> Widget
forall a b. (a -> b) -> a -> b
$ PointedList (Widget, Text) -> (Widget, Text)
forall a. PointedList a -> a
PL._focus PointedList (Widget, Text)
ts)
IO () -> (Int -> IO ()) -> Maybe Int -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Notebook -> ReadWriteAttr Notebook Int Int -> Int -> IO ()
forall a o. Eq a => o -> ReadWriteAttr o a a -> a -> IO ()
update Notebook
nb ReadWriteAttr Notebook Int Int
forall self. NotebookClass self => Attr self Int
notebookPage) Maybe Int
p
IORef (Maybe (PointedList (Widget, Text)))
-> Maybe (PointedList (Widget, Text)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SimpleNotebook -> IORef (Maybe (PointedList (Widget, Text)))
snTabs SimpleNotebook
sn) (PointedList (Widget, Text) -> Maybe (PointedList (Widget, Text))
forall a. a -> Maybe a
Just PointedList (Widget, Text)
ts)
Notebook -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetShowAll Notebook
nb
simpleNotebookOnSwitchPage :: SimpleNotebook -> (Int -> IO ()) -> IO ()
simpleNotebookOnSwitchPage :: SimpleNotebook -> (Int -> IO ()) -> IO ()
simpleNotebookOnSwitchPage SimpleNotebook
sn = IO (ConnectId Notebook) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ConnectId Notebook) -> IO ())
-> ((Int -> IO ()) -> IO (ConnectId Notebook))
-> (Int -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimpleNotebook -> Notebook
snMainWidget SimpleNotebook
sn Notebook
-> Signal Notebook (Int -> IO ())
-> (Int -> IO ())
-> IO (ConnectId Notebook)
forall object callback.
object
-> Signal object callback -> callback -> IO (ConnectId object)
`on` Signal Notebook (Int -> IO ())
forall self. NotebookClass self => Signal self (Int -> IO ())
switchPage)
update :: (Eq a) => o -> ReadWriteAttr o a a -> a -> IO ()
update :: forall a o. Eq a => o -> ReadWriteAttr o a a -> a -> IO ()
update o
w ReadWriteAttr o a a
attr a
val = do a
oldVal <- o -> ReadWriteAttr o a a -> IO a
forall o a b. o -> ReadWriteAttr o a b -> IO a
get o
w ReadWriteAttr o a a
attr
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
val a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
oldVal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ o -> [AttrOp o] -> IO ()
forall o. o -> [AttrOp o] -> IO ()
set o
w [ReadWriteAttr o a a
attr ReadWriteAttr o a a -> a -> AttrOp o
forall o a b. ReadWriteAttr o a b -> b -> AttrOp o
:= a
val]