{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Frontend.Pango.Layouts
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides abstract controls which implement 'Yi.Layout.Layout's and
-- which manage the minibuffer.
--
-- The implementation strategy is to first construct the layout
-- managers @WeightedStack@ (implementing the 'Stack' constructor) and
-- @SlidingPair@ (implementing the 'Pair' constructor), and then
-- construct 'LayoutDisplay' as a tree of these, mirroring the
-- structure of 'Layout'.

module Yi.Frontend.Pango.Layouts (
  -- * Getting the underlying widget
  WidgetLike(..),
  -- * Window layout
  LayoutDisplay,
  layoutDisplayNew,
  layoutDisplaySet,
  layoutDisplayOnDividerMove,
  -- * Miniwindow layout
  MiniwindowDisplay,
  miniwindowDisplayNew,
  miniwindowDisplaySet,
  -- * Tabs
  SimpleNotebook,
  simpleNotebookNew,
  simpleNotebookSet,
  simpleNotebookOnSwitchPage,
  -- * Utils
  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
  -- | Extracts the main widget. This is the widget to be added to the GUI.
  baseWidget :: w -> Widget

----------------------- The WeightedStack type
{- | A @WeightedStack@ is like a 'VBox' or 'HBox', except that we may
specify the ratios of the areas of the child widgets (so this
implements the 'Stack' constructor of 'Yi.Layout.Layout'.

Essentially, we implement this layout manager from scratch, by
implementing the 'sizeRequest' and 'sizeAllocate' signals by hand (see
the 'Container' documentation for details, and
http://www.ibm.com/developerworks/linux/library/l-widget-pygtk/ for an
example in Python). Ideally, we would directly subclass the abstract
class 'Container', but Gtk2hs doesn't directly support this. Instead,
we start off with the concrete class 'Fixed', and just override its
layout behaviour.
-}

newtype WeightedStack = WS Fixed
  deriving(GObject -> WeightedStack
WeightedStack -> GObject
(WeightedStack -> GObject)
-> (GObject -> WeightedStack) -> GObjectClass WeightedStack
forall o. (o -> GObject) -> (GObject -> o) -> GObjectClass o
$ctoGObject :: WeightedStack -> GObject
toGObject :: WeightedStack -> GObject
$cunsafeCastGObject :: GObject -> WeightedStack
unsafeCastGObject :: GObject -> WeightedStack
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 a b. (a -> b) -> [a] -> [b]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixed -> WeightedStack
WS Fixed
l)

-- | Requests the smallest size so that each widget gets its requested size
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 a. Num a => [a] -> a
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 a b. (a -> b) -> [a] -> [b]
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 a. Ord a => t a -> a
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 a b. (a -> b) -> t a -> t b
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 a. Ord a => t a -> a
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 a b. (a -> b) -> t a -> t b
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 b. Integral b => RelativeSize -> b
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 b. Integral b => RelativeSize -> b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Widget, RelativeSize) -> IO (Requisition, RelativeSize)
forall {self} {t}.
WidgetClass self =>
(self, t) -> IO (Requisition, t)
swreq StackDescr
s


-- | Bounds the given requisition to not exceed screen dimensions
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 a b. IO (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Requisition
r

-- | Position the children appropriately for the given width and height
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 a. Num a => [a] -> a
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 a b. (a -> b) -> [a] -> [b]
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 b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round -> Int
pos, a -> Int
forall b. Integral b => a -> b
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 a b. (a -> b) -> [a] -> [b]
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

------------------------------------------------------- SlidingPair

{-|
'SlidingPair' implements the 'Pair' constructor.

Most of what is needed is already implemented by the 'HPaned' and
'VPaned' classes. The main feature added by 'SlidingPair' is that the
divider position, *as a fraction of the available space*, remains
constant even when resizing.
-}

newtype SlidingPair = SP Paned
  deriving(GObject -> SlidingPair
SlidingPair -> GObject
(SlidingPair -> GObject)
-> (GObject -> SlidingPair) -> GObjectClass SlidingPair
forall o. (o -> GObject) -> (GObject -> o) -> GObjectClass o
$ctoGObject :: SlidingPair -> GObject
toGObject :: SlidingPair -> GObject
$cunsafeCastGObject :: GObject -> SlidingPair
unsafeCastGObject :: GObject -> SlidingPair
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

{- We want to catch the sizeAllocate signal. If this event is
called, two things could have happened: the size could have changed;
or the slider could have moved.  We want to correct the slider
position, but only if the size has changed. Furthermore, if the size
only changes in the direction /orthogonal/ to the slider, then there
is also no need to correct the slider position.

-}

  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 -- the slider was moved; store its new position
          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 -- the size was changed; restore the slider position and
             -- save the new position
          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 b. Integral b => RelativeSize -> b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Paned -> SlidingPair
SP Paned
p)

----------------------------- LayoutDisplay
-- | A container implements 'Layout's.
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 ()]
     }

-- | Tree mirroring 'Layout', which holds the layout widgets for 'LayoutDisplay'
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
    }

--- construction
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 a. a -> IO a
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)

-- | Registers a callback to a divider changing position. (There is
-- currently no way to unregister.)
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]
:)

--- changing the layout

-- | Sets the layout to the given schema.
--
-- * it is permissible to add or remove widgets in this process.
--
-- * as an optimisation, this function will first check whether the
-- layout has actually changed (so the caller need not be concerned
-- with this)
--
-- * will run 'widgetShowAll', and hence will show the underlying widgets too
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 b c d. (b -> c) -> (b, d) -> (c, d)
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 a. a -> IO a
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 a. a -> IO a
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

-- | true if the displayed layout agrees with the given schema, other
-- than divider positions
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 a. [a] -> 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 a. [a] -> 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

-- removes all widgets from the layout
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]


-- extract the main widget from the tree
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

---------------- MiniwindowDisplay
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 a. a -> IO a
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)

  -- we could be more careful here, and only remove the widgets which we need to.
  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


---------------------- SimpleNotebook
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

-- | Constructs an empty notebook
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 a. a -> IO a
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)

-- | Sets the tabs
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 a. PointedList a -> [a]
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 a. PointedList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (PointedList (Widget, Text))
curTs

  -- the common case is no change at all
  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

    -- update the tabs, if they have changed
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((Widget, Text) -> Widget) -> [(Widget, Text)] -> [Widget]
forall a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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)

    -- now update the titles if they have changed
    [(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

    -- now set the focus
    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 a. a -> IO a
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

    -- write the new status
    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)

    -- display!
    Notebook -> IO ()
forall self. WidgetClass self => self -> IO ()
widgetShowAll Notebook
nb


-- | The 'onSwitchPage' callback
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)


------------------- Utils
-- Only set an attribute if has actually changed.
-- This makes setting window titles much faster.
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]