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