diff --git a/ltk.cabal b/ltk.cabal --- a/ltk.cabal +++ b/ltk.cabal @@ -1,6 +1,6 @@ name: ltk -version: 0.15.0.5 -cabal-version: >= 1.8 +version: 0.16.1.0 +cabal-version: >=1.8 build-type: Simple license: GPL license-file: LICENSE @@ -10,29 +10,84 @@ package-url: http://code.haskell.org/ltk bug-reports: http://code.google.com/p/leksah/issues/list synopsis: Leksah tool kit -description: UI Framework used by leksah +description: + UI Framework used by leksah category: GUI author: Juergen "jutaro" Nicklisch-Franken -tested-with: GHC ==6.10 || ==6.12 || ==7.0 +tested-with: GHC ==8.2.1 || ==8.0.2 || ==7.10.3 source-repository head - type: git - location: https://github.com/leksah/ltk + type: git + location: https://github.com/leksah/ltk -Library - build-depends: Cabal >=1.6.0 && <1.23, base >=4.0.0.0 && <4.9, - containers >=0.2 && <0.6, filepath >=1.1.0 && <1.5, - glib >=0.13.0.0 && <0.14, text >=0.11.0.6 && <1.3, - mtl >=1.1.0.2 && <2.3, parsec >=2.1.0.1 && <3.2, - pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.5, - ghc -any, gtk3 >=0.13.2 && <0.15 +flag gdk-318 + description: + GDK is 3.18 or later - exposed-modules: Default MyMissing Control.Event - Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite - Graphics.UI.Editor.DescriptionPP Graphics.UI.Editor.MakeEditor - Graphics.UI.Editor.Parameters Graphics.UI.Editor.Simple - Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame - Text.PrinterParser - exposed: True - buildable: True +flag gtk-318 + description: + GTK+ is 3.18 or later + +flag gtk-320 + description: + GTK+ is 3.20 or later + +library + + if !impl(ghcjs -any) + build-depends: + ghc -any + + if flag(gdk-318) + cpp-options: -DMIN_VERSION_GDK_3_18 + pkgconfig-depends: gdk-3.0 >=3.18 + else + pkgconfig-depends: gdk-3.0 <3.18 + + if flag(gtk-318) + cpp-options: -DMIN_VERSION_GTK_3_18 + pkgconfig-depends: gtk+-3.0 >=3.18 + else + pkgconfig-depends: gdk-3.0 <3.18 + + if flag(gtk-320) + cpp-options: -DMIN_VERSION_GTK_3_20 + pkgconfig-depends: gtk+-3.0 >=3.20 + else + pkgconfig-depends: gdk-3.0 <3.20 + exposed-modules: + Default + Control.Event + Graphics.UI.Editor.Basics + Graphics.UI.Editor.Composite + Graphics.UI.Editor.DescriptionPP + Graphics.UI.Editor.MakeEditor + Graphics.UI.Editor.Parameters + Graphics.UI.Editor.Simple + Graphics.UI.Frame.Panes + Graphics.UI.Frame.Rectangle + Graphics.UI.Frame.ViewFrame + Graphics.UI.Utils + Text.PrinterParser + MyMissing + build-depends: + Cabal >=1.6.0 && <2.1, + base >=4.0.0.0 && <4.11, + base-compat >=0.9.0 && <0.10, + containers >=0.2 && <0.6, + filepath >=1.1.0 && <1.5, + text >=0.11.0.6 && <1.3, + mtl >=1.1.0.2 && <2.3, + parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, + transformers >=0.2.2.0 && <0.6, + haskell-gi-base >=0.20 && <0.21, + gi-glib >=2.0.6 && <2.1, + gi-gobject >=2.0.6 && <2.1, + gi-cairo >=1.0.6 && <1.1, + gi-gdk >=3.0.6 && <3.1, + gi-gtk >=3.0.6 && <3.1, + gi-gtk-hs >=0.3.1.0 && <0.4, + haskell-gi-overloading ==0.0.* hs-source-dirs: src + diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs --- a/src/Graphics/UI/Editor/Basics.hs +++ b/src/Graphics/UI/Editor/Basics.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Basics @@ -41,14 +42,14 @@ , propagateAsChanged ) where -import Prelude +import Prelude () +import Prelude.Compat import Text.Show -import Graphics.UI.Gtk import Data.Unique import Data.IORef import Data.Text (Text) -import Control.Monad +import Control.Monad (foldM, void) import Control.Monad.Trans (liftIO) import Graphics.UI.Editor.Parameters @@ -60,6 +61,15 @@ import Control.Arrow (first) import MyMissing (allOf) import qualified Data.Text as T (pack) +import GI.Gtk.Objects.Widget + (afterWidgetKeyReleaseEvent, afterWidgetButtonReleaseEvent, + onWidgetFocusInEvent, onWidgetFocusOutEvent, widgetGetName, + Widget(..)) +import Data.GI.Base.BasicTypes (GObject) +import Data.GI.Base.Signals (SignalHandlerId) +import Data.GI.Base.ManagedPtr (unsafeCastTo, castTo) +import GI.Gtk.Objects.Button (onButtonClicked, Button(..)) +import Control.Monad.IO.Class (MonadIO) fromString = Just . T.pack @@ -139,7 +149,7 @@ -- -- | A type for a function to register a gtk event -- | -type GtkRegFunc = forall o . GObjectClass o => o -> GtkHandler -> IO Connection +type GtkRegFunc = forall o . GObject o => o -> GtkHandler -> IO Connection -- -- | The widgets are the real event sources. @@ -163,16 +173,16 @@ Map GUIEventSelector GUIEventReg)) -emptyNotifier :: IO Notifier +emptyNotifier :: MonadIO m => m Notifier emptyNotifier = do - h <- newIORef (Map.empty,Map.empty) + h <- liftIO $ newIORef (Map.empty,Map.empty) let noti = Noti h return noti -- -- | Signal handlers for the different pane types -- -data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) +data Connection = forall alpha . GObject alpha => ConnectC alpha SignalHandlerId type Connections = [Connection] @@ -233,9 +243,9 @@ -- -- | Propagate the event with the selector from notifier to eventSource -- -propagateEvent :: Notifier -> [Notifier] -> GUIEventSelector -> IO () +propagateEvent :: MonadIO m => Notifier -> [Notifier] -> GUIEventSelector -> m () propagateEvent (Noti pairRef) eventSources eventSel = do - (handlers,ger) <- readIORef pairRef + (handlers,ger) <- liftIO $ readIORef pairRef let newGer = case Map.lookup eventSel ger of Nothing -> Map.insert eventSel ([],(eventSources,Map.empty)) ger @@ -245,17 +255,18 @@ newGer2 <- case eventSel `Map.lookup` handlers of Nothing -> return newGer Just hl -> foldM (repropagate eventSel) newGer hl - writeIORef pairRef (handlers,newGer) - where - repropagate :: GUIEventSelector + liftIO $ writeIORef pairRef (handlers,newGer) + where + repropagate :: MonadIO m + => GUIEventSelector -> Map GUIEventSelector GUIEventReg -> (Unique, GUIEvent -> IO GUIEvent) - -> IO (Map GUIEventSelector GUIEventReg) + -> m (Map GUIEventSelector GUIEventReg) repropagate eventSet ger (unique,hand) = case Map.lookup eventSel ger of Just (cids,(notifiers,um)) -> do - lu <- mapM (\es -> registerEvent es eventSel hand) + lu <- mapM (\es -> liftIO $ registerEvent es eventSel hand) notifiers let jl = map (first fromJust) $ filter (isJust.fst) @@ -270,23 +281,24 @@ -- activateEvent - :: GObjectClass o => + :: GObject o => o -> Notifier - -> Maybe (o -> IO Bool -> IO Connection) + -> Maybe (o -> IO Bool -> IO SignalHandlerId) -> GUIEventSelector -> IO () activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do - let registerFunc = fromMaybe (getStandardRegFunction eventSel) mbRegisterFunc + let registerFunc = maybe (getStandardRegFunction eventSel) + (\f w h -> ConnectC w <$> f w h) mbRegisterFunc cid <- registerFunc widget (do (hi,_) <- readIORef pairRef case Map.lookup eventSel hi of Nothing -> return False Just [] -> return False Just handlers -> do - name <- if widget `isA` gTypeWidget - then widgetGetName (castToWidget widget) - else return "no widget - no name" :: IO Text + name <- castTo Widget widget >>= \case + Just w -> widgetGetName w + Nothing -> return "no widget - no name" eventList <- mapM ((\f -> do let ev = GUIEvent eventSel "" False f ev) . snd) handlers @@ -304,11 +316,11 @@ -- | A convinence method for not repeating this over and over again -- getStandardRegFunction :: GUIEventSelector -> GtkRegFunc -getStandardRegFunction FocusOut = \w h -> liftM ConnectC $ on (castToWidget w) focusOutEvent $ liftIO h -getStandardRegFunction FocusIn = \w h -> liftM ConnectC $ on (castToWidget w) focusInEvent $ liftIO h -getStandardRegFunction ButtonPressed = \w h -> liftM ConnectC $ after (castToWidget w) buttonReleaseEvent $ liftIO h -getStandardRegFunction KeyPressed = \w h -> liftM ConnectC $ after (castToWidget w) keyReleaseEvent $ liftIO h -getStandardRegFunction Clicked = \w h -> liftM ConnectC $ on (castToButton w) buttonActivated $ void $ liftIO h +getStandardRegFunction FocusOut = \w h -> fmap (ConnectC w) $ unsafeCastTo Widget w >>= (`onWidgetFocusOutEvent` const h) +getStandardRegFunction FocusIn = \w h -> fmap (ConnectC w) $ unsafeCastTo Widget w >>= (`onWidgetFocusInEvent` const h) +getStandardRegFunction ButtonPressed = \w h -> fmap (ConnectC w) $ unsafeCastTo Widget w >>= (`afterWidgetButtonReleaseEvent` const h) +getStandardRegFunction KeyPressed = \w h -> fmap (ConnectC w) $ unsafeCastTo Widget w >>= (`afterWidgetKeyReleaseEvent` const h) +getStandardRegFunction Clicked = \w h -> fmap (ConnectC w) $ unsafeCastTo Button w >>= (`onButtonClicked` void h) getStandardRegFunction _ = error "Basic>>getStandardRegFunction: no original GUI event" registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Maybe Unique] diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs --- a/src/Graphics/UI/Editor/Composite.hs +++ b/src/Graphics/UI/Editor/Composite.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Composite @@ -32,7 +34,6 @@ , dependenciesEditor ) where -import Graphics.UI.Gtk import Control.Monad import Data.IORef import Data.Maybe @@ -41,6 +42,7 @@ import Default import Control.Event +import Graphics.UI.Utils import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor @@ -49,18 +51,63 @@ import Distribution.Simple (orEarlierVersion, orLaterVersion, - VersionRange(..), + VersionRange, PackageName(..), Dependency(..), +#if MIN_VERSION_Cabal(2,0,0) + unPackageName, + mkPackageName, +#endif PackageIdentifier(..)) import Distribution.Text (simpleParse, display) import Distribution.Package (pkgName) -import Data.Version (Version(..)) import MyMissing (forceJust) -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Debug.Trace (trace) +import GI.Gtk + (gridSetRowSpacing, gridSetColumnSpacing, orientableSetOrientation, + widgetSetHexpand, widgetSetVexpand, toWidget, buttonBoxNew, + noWidget, widgetSetValign, widgetSetHalign, panedNew, gridNew, + setCellRendererTextText, noTreeViewColumn, noAdjustment, + FileChooserAction, treeModelGetPath, treeSelectionGetSelected, + treeViewScrollToCell, treeViewGetColumn, treeSelectionSelectPath, + onButtonClicked, onTreeSelectionChanged, treeViewSetHeadersVisible, + cellLayoutPackStart, cellRendererTextNew, treeViewAppendColumn, + treeViewColumnSetResizable, treeViewColumnSetTitle, + treeViewColumnNew, treeSelectionSetMode, treeViewGetSelection, + scrolledWindowSetMinContentHeight, scrolledWindowSetPolicy, + scrolledWindowNew, widgetSetSizeRequest, treeViewNewWithModel, + afterTreeModelRowDeleted, afterTreeModelRowInserted, + buttonNewWithLabel, hButtonBoxNew, ButtonBox(..), vButtonBoxNew, + CellRendererText, containerRemove, widgetSetSensitive, + containerGetChildren, widgetHide, widgetShowAll, boxPackEnd, + panedPack2, panedPack1, hPanedNew, Paned(..), vPanedNew, + containerAdd, boxPackStart, vBoxNew, Box(..), hBoxNew, Widget(..)) +import Data.GI.Base.ManagedPtr (unsafeCastTo, castTo) +import GI.Gtk.Enums + (Orientation(..), PositionType(..), Align(..), ShadowType(..), + SelectionMode(..), PolicyType(..)) +import Data.GI.Gtk.ModelView.CellLayout + (cellLayoutSetDataFunction) +import Data.GI.Gtk.ModelView.SeqStore + (seqStoreAppend, seqStoreClear, seqStoreNew, seqStoreGetValue, + seqStoreRemove, seqStoreToList, SeqStore(..)) +import Data.GI.Gtk.ModelView.Types + (treePathNewFromIndices', equalManagedPtr) +import GI.Gtk.Structs.TreePath (treePathGetIndices) +import Distribution.Version + (Version(..), +#if MIN_VERSION_Cabal(2,0,0) + majorBoundVersion, +#endif + withinVersion, intersectVersionRanges, unionVersionRanges, + earlierVersion, laterVersion, thisVersion, anyVersion, + foldVersionRange') +#if !MIN_VERSION_Cabal(2,0,0) +mkPackageName = PackageName +#endif + -- -- | An editor which composes two subeditors -- @@ -77,16 +124,15 @@ core <- readIORef coreRef case core of Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box fstFrame PackGrow 0 - boxPackStart box sndFrame PackGrow 0 - containerAdd widget box + grid <- gridNew + orientableSetOrientation grid $ getParameter paraOrientation parameters + gridSetColumnSpacing grid 1 + gridSetRowSpacing grid 1 + setPrimaryExpand grid fstFrame True + containerAdd grid fstFrame + setPrimaryExpand grid sndFrame True + containerAdd grid sndFrame + containerAdd widget grid inj1 v1 inj2 v2 writeIORef coreRef (Just (fst,snd)) @@ -123,17 +169,15 @@ core <- readIORef coreRef case core of Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box frame1 PackGrow 0 - boxPackStart box frame2 PackGrow 0 - boxPackStart box frame3 PackGrow 0 - containerAdd widget box + grid <- gridNew + orientableSetOrientation grid $ getParameter paraOrientation parameters + setPrimaryExpand grid frame1 True + containerAdd grid frame1 + setPrimaryExpand grid frame2 True + containerAdd grid frame2 + setPrimaryExpand grid frame3 True + containerAdd grid frame3 + containerAdd widget grid inj1 v1 inj2 v2 inj3 v3 @@ -171,11 +215,9 @@ core <- readIORef coreRef case core of Nothing -> do - paned <- case getParameter paraDirection parameters of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) + paned <- panedNew $ case getParameter paraOrientation parameters of + OrientationHorizontal -> OrientationVertical + OrientationVertical -> OrientationHorizontal panedPack1 paned fstFrame True True panedPack2 paned sndFrame True True containerAdd widget paned @@ -212,30 +254,29 @@ core <- readIORef coreRef case core of Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) + grid <- gridNew + orientableSetOrientation grid $ getParameter paraOrientation parameters + gridSetColumnSpacing grid 1 + gridSetRowSpacing grid 1 be@(boolFrame,inj1,ext1) <- boolEditor (paraName <<<- ParaName boolLabel $ emptyParams) notifierBool - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box + setPrimaryAlign grid boolFrame AlignStart + containerAdd grid boolFrame + containerAdd widget grid registerEvent notifierBool Clicked (onClickedHandler widget coreRef childRef cNoti) propagateEvent notifier [notifierBool] MayHaveChanged case mbVal of Nothing -> inj1 (not positive) Just val -> do (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 + setPrimaryExpand grid childWidget True + containerAdd grid childWidget widgetShowAll childWidget inj1 positive inj2 val - writeIORef coreRef (Just (be,box)) - Just (be@(boolFrame,inj1,extt),box) -> do + writeIORef coreRef (Just (be,grid)) + Just (be@(boolFrame,inj1,extt),grid) -> do hasChild <- hasChildEditor childRef case mbVal of Nothing -> @@ -255,7 +296,8 @@ else do inj1 positive (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 + setPrimaryExpand grid childWidget True + containerAdd grid childWidget widgetShowAll childWidget inj2 val) (do @@ -272,7 +314,7 @@ case value of Nothing -> return Nothing Just value -> return (Just (Just value)) - otherwise -> return (Just Nothing)) + _ -> return (Just Nothing)) parameters notifier where @@ -280,7 +322,7 @@ core <- readIORef coreRef case core of Nothing -> error "Impossible" - Just (be@(boolFrame,inj1,ext1),vBox) -> do + Just (be@(boolFrame,inj1,ext1),grid) -> do mbBool <- ext1 case mbBool of Just bool -> @@ -293,9 +335,10 @@ else do hasChild <- hasChildEditor childRef (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti - children <- containerGetChildren vBox - unless (childWidget `elem` children) $ - boxPackEnd vBox childWidget PackNatural 0 + children <- containerGetChildren grid + unless (any (equalManagedPtr childWidget) children) $ do + setPrimaryAlign grid childWidget AlignStart + containerAdd grid childWidget inj2 getDefault widgetShowAll childWidget Nothing -> return () @@ -330,38 +373,36 @@ core <- readIORef coreRef case core of Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) + grid <- gridNew + orientableSetOrientation grid $ getParameter paraOrientation parameters be@(boolFrame,inj1,ext1) <- boolEditor (paraName <<<- ParaName boolLabel $ emptyParams) notifierBool - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box + setPrimaryAlign grid boolFrame AlignStart + containerAdd grid boolFrame + containerAdd widget grid registerEvent notifierBool Clicked (onClickedHandler widget coreRef childRef cNoti) propagateEvent notifier [notifierBool] MayHaveChanged case mbVal of (False,val) -> do (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 + setPrimaryExpand grid childWidget True + containerAdd grid childWidget widgetShowAll childWidget inj1 ( not positive) inj2 val widgetSetSensitive childWidget False (True,val) -> do (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 + setPrimaryExpand grid childWidget True + containerAdd grid childWidget widgetShowAll childWidget inj1 positive inj2 val widgetSetSensitive childWidget True - writeIORef coreRef (Just (be,box)) - Just (be@(boolFrame,inj1,extt),box) -> do + writeIORef coreRef (Just (be,grid)) + Just (be@(boolFrame,inj1,extt),grid) -> do hasChild <- hasChildEditor childRef case mbVal of (False,val) -> @@ -381,7 +422,8 @@ else do inj1 positive (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 + setPrimaryExpand grid childWidget True + containerAdd grid childWidget widgetSetSensitive childWidget True inj2 val) (do @@ -398,7 +440,7 @@ case value of Nothing -> return Nothing Just value -> return (Just (True, value)) - otherwise -> do + _ -> do (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti value <- ext2 case value of @@ -411,7 +453,7 @@ core <- readIORef coreRef case core of Nothing -> error "Impossible" - Just (be@(boolFrame,inj1,ext1),vBox) -> do + Just (be@(boolFrame,inj1,ext1),grid) -> do mbBool <- ext1 case mbBool of Just bool -> @@ -430,7 +472,8 @@ widgetSetSensitive childWidget True else do (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd vBox childWidget PackNatural 0 + setPrimaryAlign grid childWidget AlignStart + containerAdd grid childWidget inj2 getDefault widgetSetSensitive childWidget True Nothing -> return () @@ -470,38 +513,38 @@ case core of Nothing -> do registerEvent noti1 Clicked (onClickedHandler widget coreRef) - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box + grid <- gridNew + orientableSetOrientation grid $ getParameter paraOrientation parameters + gridSetColumnSpacing grid 1 + gridSetRowSpacing grid 1 + setPrimaryAlign grid boolFrame AlignStart + setPrimaryAlign grid leftFrame AlignStart + setPrimaryAlign grid rightFrame AlignStart + containerAdd grid boolFrame + containerAdd widget grid case v of Left vl -> do - boxPackStart box leftFrame PackNatural 0 + containerAdd grid leftFrame inj2 vl inj3 getDefault inj1 True Right vr -> do - boxPackStart box rightFrame PackNatural 0 + containerAdd grid rightFrame inj3 vr inj2 getDefault inj1 False - writeIORef coreRef (Just (be,le,re,box)) - Just ((_,inj1,_),(leftFrame,inj2,_),(rightFrame,inj3,_),box) -> + writeIORef coreRef (Just (be,le,re,grid)) + Just ((_,inj1,_),(leftFrame,inj2,_),(rightFrame,inj3,_),grid) -> case v of Left vl -> do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 + containerRemove grid rightFrame + containerAdd grid leftFrame inj2 vl inj3 getDefault inj1 True Right vr -> do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 + containerRemove grid leftFrame + containerAdd grid rightFrame inj3 vr inj2 getDefault inj1 False) @@ -529,18 +572,18 @@ core <- readIORef coreRef case core of Nothing -> error "Impossible" - Just (be@(_,_,ext1),(leftFrame,_,_),(rightFrame,_,_),box) -> do + Just (be@(_,_,ext1),(leftFrame,_,_),(rightFrame,_,_),grid) -> do mbBool <- ext1 case mbBool of Just bool -> if bool then do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 - widgetShowAll box + containerRemove grid rightFrame + containerAdd grid leftFrame + widgetShowAll grid else do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 - widgetShowAll box + containerRemove grid leftFrame + containerAdd grid rightFrame + widgetShowAll grid Nothing -> return () return event{gtkReturn=True} @@ -549,7 +592,7 @@ -- and a nontrivial: -- [("Package",\(Dependency str _) -> [cellText := str]) -- ,("Version",\(Dependency _ vers) -> [cellText := showVersionRange vers])]) -data ColumnDescr row = ColumnDescr Bool [(Text, row -> [AttrOp CellRendererText])] +data ColumnDescr row = ColumnDescr Bool [(Text, CellRendererText -> row -> IO ())] -- -- | An editor with a subeditor, of which a list of items can be selected @@ -568,41 +611,32 @@ core <- readIORef coreRef case core of Nothing -> do - (box,buttonBox) <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - bb <- vButtonBoxNew - return (castToBox b,castToButtonBox bb) - Vertical -> do - b <- vBoxNew False 1 - bb <- hButtonBoxNew - return (castToBox b,castToButtonBox bb) + let orientation = getParameter paraOrientation parameters + grid <- gridNew + orientableSetOrientation grid orientation + buttonBox <- case orientation of + OrientationHorizontal -> buttonBoxNew OrientationVertical + OrientationVertical -> buttonBoxNew OrientationHorizontal (frameS,injS,extS) <- singleEditor sParams cnoti mapM_ (propagateEvent notifier [cnoti]) allGUIEvents - addButton <- buttonNewWithLabel ("Add" :: Text) - removeButton <- buttonNewWithLabel ("Remove" :: Text) + addButton <- buttonNewWithLabel "Add" + removeButton <- buttonNewWithLabel "Remove" containerAdd buttonBox addButton containerAdd buttonBox removeButton - listStore <- listStoreNew ([]:: [alpha]) - activateEvent listStore notifier - (Just (\ w h -> do - res <- after (castToTreeModel w) rowInserted (\ _ _ -> - void h) - return (ConnectC res))) MayHaveChanged - activateEvent listStore notifier - (Just (\ w h -> do - res <- after (castToTreeModel w) rowDeleted (\ _ -> - void h) - return (ConnectC res))) MayHaveChanged - treeView <- treeViewNewWithModel listStore + seqStore <- seqStoreNew ([]:: [alpha]) + activateEvent seqStore notifier + (Just (\ w h -> afterTreeModelRowInserted w (\ _ _ -> void h))) MayHaveChanged + activateEvent seqStore notifier + (Just (\ w h -> afterTreeModelRowDeleted w (\ _ -> void h))) MayHaveChanged + treeView <- treeViewNewWithModel seqStore let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest treeView) minSize - sw <- scrolledWindowNew Nothing Nothing + sw <- scrolledWindowNew noAdjustment noAdjustment containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic scrolledWindowSetMinContentHeight sw (snd minSize) sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle + treeSelectionSetMode sel SelectionModeSingle mapM_ (\(str,func) -> do col <- treeViewColumnNew treeViewColumnSetTitle col str @@ -610,103 +644,107 @@ treeViewAppendColumn treeView col renderer <- cellRendererTextNew cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore func + cellLayoutSetDataFunction col renderer seqStore (func renderer) ) columnsDD treeViewSetHeadersVisible treeView showHeaders - on sel treeSelectionSelectionChanged $ selectionHandler sel listStore injS - boxPackStart box sw PackGrow 0 - boxPackStart box buttonBox PackNatural 0 - boxPackStart box frameS PackNatural 0 - activateEvent (castToWidget treeView) notifier Nothing FocusOut - containerAdd widget box - listStoreClear listStore - mapM_ (listStoreAppend listStore) + onTreeSelectionChanged sel $ selectionHandler sel seqStore injS + setPrimaryExpand grid sw True + setSecondaryExpand grid sw True + containerAdd grid sw + setPrimaryAlign grid buttonBox AlignEnd + setSecondaryExpand grid buttonBox True + containerAdd grid buttonBox + setPrimaryAlign grid frameS AlignEnd + setSecondaryExpand grid frameS True + containerAdd grid frameS + activateEvent treeView notifier Nothing FocusOut + containerAdd widget grid + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) (case mbSort of Nothing -> vs Just sortF -> sortF vs) - on addButton buttonActivated $ do + onButtonClicked addButton $ do mbv <- extS case mbv of Just v -> do case mbReplace of Nothing -> return () Just replaceF -> do - cont <- listStoreToList listStore - mapM_ (listStoreRemove listStore . fst) + cont <- seqStoreToList seqStore + mapM_ (seqStoreRemove seqStore . fst) . filter (\(_,e) -> replaceF v e) $ zip [0..] cont case mbSort of Nothing -> do - listStoreAppend listStore v + seqStoreAppend seqStore v return () Just sortF -> do - cont <- listStoreToList listStore - listStoreClear listStore - mapM_ (listStoreAppend listStore) (sortF (v:cont)) - cont <- listStoreToList listStore + cont <- seqStoreToList seqStore + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) (sortF (v:cont)) + cont <- seqStoreToList seqStore case elemIndex v cont of Just idx -> do - treeSelectionSelectPath sel [idx] - mbCol <- treeViewGetColumn treeView 0 - case mbCol of - Nothing -> return () - Just col -> treeViewScrollToCell treeView (Just [idx]) Nothing Nothing + path <- treePathNewFromIndices' [fromIntegral idx] + treeSelectionSelectPath sel path + treeViewScrollToCell treeView (Just path) noTreeViewColumn False 0.0 0.0 Nothing -> return () Nothing -> return () - on removeButton buttonActivated $ do + onButtonClicked removeButton $ do mbi <- treeSelectionGetSelected sel case mbi of - Nothing -> return () - Just iter -> do - [i] <- treeModelGetPath listStore iter - listStoreRemove listStore i - writeIORef coreRef (Just listStore) + (True, _, iter) -> do + [i] <- treeModelGetPath seqStore iter >>= treePathGetIndices + seqStoreRemove seqStore i + _ -> return () + writeIORef coreRef (Just seqStore) injS getDefault - Just listStore -> do - listStoreClear listStore - mapM_ (listStoreAppend listStore) + Just seqStore -> do + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) (case mbSort of Nothing -> vs Just sortF -> sortF vs)) (do core <- readIORef coreRef case core of Nothing -> return Nothing - Just listStore -> do - v <- listStoreToList listStore + Just seqStore -> do + v <- seqStoreToList seqStore return (Just v)) (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) notifier where --- selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () - selectionHandler sel listStore inj = do +-- selectionHandler :: TreeSelection -> SeqStore a -> Injector a -> IO () + selectionHandler sel seqStore inj = do ts <- treeSelectionGetSelected sel case ts of - Nothing -> return () - Just iter -> do - [i] <- treeModelGetPath listStore iter - v <- listStoreGetValue listStore i + (True, _, iter) -> do + [i] <- treeModelGetPath seqStore iter >>= treePathGetIndices + v <- seqStoreGetValue seqStore i inj v return () + _ -> return () filesEditor :: Maybe FilePath -> FileChooserAction -> Text -> Editor [FilePath] filesEditor fp act label p = multisetEditor - (ColumnDescr False [("", \ row -> [cellText := T.pack row])]) + (ColumnDescr False [("", \cell -> setCellRendererTextText cell . T.pack)]) (fileEditor fp act label, emptyParams) (Just sort) (Just (==)) - (paraShadow <<<- ParaShadow ShadowIn $ - paraDirection <<<- ParaDirection Vertical $ p) + (paraShadow <<<- ParaShadow ShadowTypeIn $ + paraOrientation <<<- ParaOrientation OrientationVertical $ p) textsEditor :: (Text -> Bool) -> Bool -> Editor [Text] textsEditor validation trimBlanks p = multisetEditor - (ColumnDescr False [("", \ row -> [cellText := row])]) + (ColumnDescr False [("", setCellRendererTextText)]) (textEditor validation trimBlanks, emptyParams) (Just sort) (Just (==)) - (paraShadow <<<- ParaShadow ShadowIn $ p) + (paraShadow <<<- ParaShadow ShadowTypeIn $ p) dependencyEditor :: [PackageIdentifier] -> Editor Dependency dependencyEditor packages para noti = do @@ -714,32 +752,32 @@ (comboEntryEditor ((sort . nub) (map (T.pack . display . pkgName) packages)) , paraName <<<- ParaName "Select" $ emptyParams) (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) - (paraDirection <<<- ParaDirection Vertical $ para) + (paraOrientation <<<- ParaOrientation OrientationVertical $ para) noti - let pinj (Dependency pn@(PackageName s) v) = inj (T.pack s,v) + let pinj (Dependency pn v) = inj (T.pack (unPackageName pn),v) let pext = do mbp <- ext case mbp of Nothing -> return Nothing Just ("",v) -> return Nothing - Just (s,v) -> return (Just $ Dependency (PackageName (T.unpack s)) v) + Just (s,v) -> return (Just $ Dependency (mkPackageName (T.unpack s)) v) return (wid,pinj,pext) dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] dependenciesEditor packages p = multisetEditor - (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := T.pack str]) - ,("Version",\(Dependency _ vers) -> [cellText := T.pack $ display vers])]) + (ColumnDescr True [("Package",\cell (Dependency pn _) -> setCellRendererTextText cell $ T.pack (unPackageName pn)) + ,("Version",\cell (Dependency _ vers) -> setCellRendererTextText cell $ T.pack $ display vers)]) (dependencyEditor packages, - paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) - $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + paraHAlign <<<- ParaHAlign AlignFill + $ paraVAlign <<<- ParaVAlign AlignCenter $ emptyParams) (Just (sortBy (\ (Dependency p1 _) (Dependency p2 _) -> compare p1 p2))) (Just (\ (Dependency p1 _) (Dependency p2 _) -> p1 == p2)) - (paraShadow <<<- ParaShadow ShadowIn - $ paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) - $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) - $ paraDirection <<<- ParaDirection Vertical + (paraShadow <<<- ParaShadow ShadowTypeIn + $ paraHAlign <<<- ParaHAlign AlignFill + $ paraVAlign <<<- ParaVAlign AlignCenter + $ paraOrientation <<<- ParaOrientation OrientationVertical $ paraPack <<<- ParaPack PackGrow $ p) @@ -751,80 +789,84 @@ (pairEditor (comboSelectionEditor v1 (T.pack . show), emptyParams) (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), - paraDirection <<<- ParaDirection Vertical $ + paraOrientation <<<- ParaOrientation OrientationVertical $ paraName <<<- ParaName "Simple" $ - paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) $ - paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) $ - paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) $ - paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) $ emptyParams) + paraHAlign <<<- ParaHAlign AlignStart $ + paraVAlign <<<- ParaVAlign AlignStart $ + paraMargin <<<- ParaMargin (0, 0, 0, 0) $ emptyParams) (tupel3Editor (comboSelectionEditor v2 (T.pack . show), emptyParams) (versionRangeEditor, - paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + paraShadow <<<- ParaShadow ShadowTypeIn $ emptyParams) (versionRangeEditor, - paraShadow <<<- ParaShadow ShadowIn $ emptyParams), + paraShadow <<<- ParaShadow ShadowTypeIn $ emptyParams), paraName <<<- ParaName "Complex" $ - paraDirection <<<- ParaDirection Vertical $ - paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) $ - paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) $ - paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) $ - paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) $ emptyParams) + paraOrientation <<<- ParaOrientation OrientationVertical $ + paraHAlign <<<- ParaHAlign AlignStart $ + paraVAlign <<<- ParaVAlign AlignStart $ + paraMargin <<<- ParaMargin (0, 0, 0, 0) $ emptyParams) "Select version range", emptyParams) False "Any Version" - (paraDirection <<<- ParaDirection Vertical $ para) + (paraOrientation <<<- ParaOrientation OrientationVertical $ para) noti - let vrinj AnyVersion = inj Nothing - vrinj (WildcardVersion v) = inj (Just (Left (WildcardVersionS,v))) - vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) - vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) - vrinj (EarlierVersion v) = inj (Just (Left (EarlierVersionS,v))) - vrinj (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrLaterVersionS,v1))) - vrinj (UnionVersionRanges (LaterVersion v1) (ThisVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrLaterVersionS,v1))) - vrinj (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrEarlierVersionS,v1))) - vrinj (UnionVersionRanges (EarlierVersion v1) (ThisVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrEarlierVersionS,v1))) - vrinj (UnionVersionRanges v1 v2)= inj (Just (Right (UnionVersionRangesS,v1,v2))) - vrinj (IntersectVersionRanges v1 v2) - = inj (Just (Right (IntersectVersionRangesS,v1,v2))) + let vrinj = inj . snd . foldVersionRange' + (anyVersion, Nothing) + (\v -> (thisVersion v, Just (Left (ThisVersionS,v)))) + (\v -> (laterVersion v, Just (Left (LaterVersionS,v)))) + (\v -> (earlierVersion v, Just (Left (EarlierVersionS,v)))) + (\v -> (unionVersionRanges (thisVersion v) (laterVersion v), Just (Left (ThisOrLaterVersionS,v)))) + (\v -> (unionVersionRanges (thisVersion v) (earlierVersion v), Just (Left (ThisOrEarlierVersionS,v)))) + (\v1 v2 -> (withinVersion v1, Just (Left (WildcardVersionS,v1)))) +#if MIN_VERSION_Cabal(2,0,0) + (\v1 v2 -> (majorBoundVersion v1, Just (Left (MajorBoundVersionS,v1)))) +#endif + (\(vr1, r1) (vr2, r2) -> (unionVersionRanges vr1 vr2, Just (Right (UnionVersionRangesS,vr1,vr2)))) + (\(vr1, r1) (vr2, r2) -> (intersectVersionRanges vr1 vr2, Just (Right (IntersectVersionRangesS,vr1,vr2)))) + id let vrext = do mvr <- ext case mvr of - Nothing -> return (Just AnyVersion) - Just Nothing -> return (Just AnyVersion) - Just (Just (Left (ThisVersionS,v))) -> return (Just (ThisVersion v)) - Just (Just (Left (WildcardVersionS,v))) -> return (Just (WildcardVersion v)) - Just (Just (Left (LaterVersionS,v))) -> return (Just (LaterVersion v)) - Just (Just (Left (EarlierVersionS,v))) -> return (Just (EarlierVersion v)) + Nothing -> return (Just anyVersion) + Just Nothing -> return (Just anyVersion) + Just (Just (Left (ThisVersionS,v))) -> return (Just (thisVersion v)) + Just (Just (Left (WildcardVersionS,v))) -> return (Just (withinVersion v)) +#if MIN_VERSION_Cabal(2,0,0) + Just (Just (Left (MajorBoundVersionS,v))) -> return (Just (majorBoundVersion v)) +#endif + Just (Just (Left (LaterVersionS,v))) -> return (Just (laterVersion v)) + Just (Just (Left (EarlierVersionS,v))) -> return (Just (earlierVersion v)) - Just (Just (Left (ThisOrLaterVersionS,v))) -> return (Just (orLaterVersion v)) - Just (Just (Left (ThisOrEarlierVersionS,v))) -> return (Just (orEarlierVersion v)) + Just (Just (Left (ThisOrLaterVersionS,v))) -> return (Just (orLaterVersion v)) + Just (Just (Left (ThisOrEarlierVersionS,v))) -> return (Just (orEarlierVersion v)) Just (Just (Right (UnionVersionRangesS,v1,v2))) - -> return (Just (UnionVersionRanges v1 v2)) + -> return (Just (unionVersionRanges v1 v2)) Just (Just (Right (IntersectVersionRangesS,v1,v2))) - -> return (Just (IntersectVersionRanges v1 v2)) + -> return (Just (intersectVersionRanges v1 v2)) return (wid,vrinj,vrext) where - v1 = [ThisVersionS,WildcardVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] + v1 = [ThisVersionS,WildcardVersionS +#if MIN_VERSION_Cabal(2,0,0) + ,MajorBoundVersionS +#endif + ,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] v2 = [UnionVersionRangesS,IntersectVersionRangesS] -data Version1 = ThisVersionS | WildcardVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS +data Version1 = ThisVersionS | WildcardVersionS | MajorBoundVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS deriving (Eq) instance Show Version1 where - show ThisVersionS = "This Version" - show WildcardVersionS = "Wildcard Version" - show LaterVersionS = "Later Version" - show ThisOrLaterVersionS = "This or later Version" - show EarlierVersionS = "Earlier Version" + show ThisVersionS = "This Version" + show WildcardVersionS = "Wildcard Version" + show MajorBoundVersionS = "Major Bound Version" + show LaterVersionS = "Later Version" + show ThisOrLaterVersionS = "This or later Version" + show EarlierVersionS = "Earlier Version" show ThisOrEarlierVersionS = "This or earlier Version" data Version2 = UnionVersionRangesS | IntersectVersionRangesS deriving (Eq) instance Show Version2 where - show UnionVersionRangesS = "Union Version Ranges" - show IntersectVersionRangesS = "Intersect Version Ranges" + show UnionVersionRangesS = "Union Version Ranges" + show IntersectVersionRangesS = "Intersect Version Ranges" versionEditor :: Editor Version versionEditor para noti = do @@ -847,13 +889,13 @@ where getDefault = forceJust (simpleParse "0") "PackageEditor>>default version" instance Default VersionRange - where getDefault = AnyVersion + where getDefault = anyVersion instance Default Dependency where getDefault = Dependency getDefault getDefault instance Default PackageName - where getDefault = PackageName getDefault + where getDefault = mkPackageName getDefault diff --git a/src/Graphics/UI/Editor/DescriptionPP.hs b/src/Graphics/UI/Editor/DescriptionPP.hs --- a/src/Graphics/UI/Editor/DescriptionPP.hs +++ b/src/Graphics/UI/Editor/DescriptionPP.hs @@ -21,7 +21,6 @@ , flattenFieldDescriptionPPToS ) where -import Graphics.UI.Gtk import Control.Monad import qualified Text.PrettyPrint.HughesPJ as PP import qualified Text.ParserCombinators.Parsec as P @@ -36,6 +35,7 @@ import Data.Text (Text) import Data.Maybe (fromMaybe) import qualified Control.Arrow as A (Arrow(..)) +import GI.Gtk.Objects.Widget (Widget(..)) data FieldDescriptionPP alpha gamma = FDPP { parameters :: Parameters diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- --group_Test -- Module : Graphics.UI.Editor.MakeEditor @@ -29,19 +30,69 @@ ) where -import Graphics.UI.Gtk -import Control.Monad +import Prelude () +import Prelude.Compat +import Control.Monad (foldM, when) import Data.List (unzip4, intersperse) import Data.Text (Text) import Data.Monoid ((<>), mconcat) import Control.Event +import Graphics.UI.Utils import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics --import Graphics.UI.Frame.ViewFrame -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isNothing, fromJust) import Data.IORef (newIORef) -import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..)) +import GI.Gtk.Objects.Widget + (toWidget, widgetSetName, widgetSetSizeRequest, Widget(..)) +import GI.Gtk.Objects.Notebook + (setNotebookEnablePopup, notebookSetCurrentPage, + notebookAppendPage, notebookSetScrollable, notebookSetShowTabs, + notebookSetTabPos, notebookNew, Notebook(..)) +import GI.Gtk.Objects.ScrolledWindow + (scrolledWindowSetPolicy, scrolledWindowNew) +import GI.Gtk.Objects.TreeView + (treeViewSetHeadersVisible, treeViewAppendColumn, + treeViewGetSelection, treeViewNewWithModel) +import GI.Gtk.Objects.TreeSelection + (onTreeSelectionChanged, + treeSelectionSelectPath, treeSelectionSetMode) +import GI.Gtk.Objects.CellRendererText + (setCellRendererTextText, cellRendererTextNew) +import GI.Gtk.Objects.TreeViewColumn (treeViewColumnNew) +import GI.Gtk.Interfaces.CellLayout + (cellLayoutSetCellDataFunc, cellLayoutPackStart) +import Data.GI.Base.Signals (on) +import GI.Gtk.Objects.HBox (hBoxNew) +import GI.Gtk.Objects.Container + (toContainer, Container(..), containerAdd) +import GI.Gtk.Objects.Box (Box(..), boxPackEnd, boxPackStart) +import GI.Gtk.Objects.VBox (vBoxNew) +import GI.Gtk.Objects.Alignment (alignmentSetPadding, alignmentNew) +import GI.Gtk.Objects.Frame + (frameSetLabel, frameSetShadowType, frameNew) +import GI.Gtk.Objects.Bin (Bin(..), binGetChild) +import GI.Gtk.Enums + (Orientation(..), Align(..), SelectionMode(..), PolicyType(..), + PositionType(..)) +import Data.GI.Base.ManagedPtr (castTo, unsafeCastTo) +import Data.GI.Gtk.ModelView.CustomStore (customStoreGetRow) +import GI.Gtk.Objects.Adjustment (noAdjustment) +import Data.GI.Gtk.ModelView.SeqStore (SeqStore(..), seqStoreNew) +import GI.Gtk.Objects.Label (labelNew) +import Control.Exception (catch) +import Data.GI.Base.BasicTypes (UnexpectedNullPointerReturn(..), nullToNothing) +import GI.Gtk.Structs.TreePath (treePathNewFirst) +import Data.GI.Gtk.ModelView.Types + (treeSelectionGetSelectedRows', treePathGetIndices') +import Control.Monad.IO.Class (MonadIO(..), MonadIO) +import GI.Gtk + (orientableSetOrientation, Orientation, widgetSetVexpand, + widgetSetHexpand, widgetSetMarginEnd, widgetSetMarginStart, + widgetSetMarginBottom, widgetSetMarginTop, noWidget, + widgetSetValign, widgetSetHalign, gridNew) +import Data.Foldable (forM_) -- -- | A constructor type for a field desciption @@ -71,19 +122,19 @@ -- -- | Construct a new notebook -- -newNotebook :: IO Notebook +newNotebook :: MonadIO m => m Notebook newNotebook = do nb <- notebookNew - notebookSetTabPos nb PosTop + notebookSetTabPos nb PositionTypeTop notebookSetShowTabs nb True notebookSetScrollable nb True - notebookSetPopup nb True + setNotebookEnablePopup nb True return nb -buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) -buildEditor (FD paras editorf) v = editorf v -buildEditor (HFD paras descrs) v = buildBoxEditor descrs Horizontal v -buildEditor (VFD paras descrs) v = buildBoxEditor descrs Vertical v +buildEditor :: (Applicative m, MonadIO m) => FieldDescription alpha -> alpha -> m (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildEditor (FD paras editorf) v = liftIO $ editorf v +buildEditor (HFD paras descrs) v = buildBoxEditor descrs OrientationHorizontal v +buildEditor (VFD paras descrs) v = buildBoxEditor descrs OrientationVertical v buildEditor (NFD pairList) v = do nb <- newNotebook notebookSetShowTabs nb False @@ -91,62 +142,70 @@ let (widgets, setInjs, getExts, notifiers) = unzip4 resList notifier <- emptyNotifier mapM_ (\ (labelString, widget) -> do - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw widget - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw labelString) + sw <- scrolledWindowNew noAdjustment noAdjustment + containerAdd sw widget + scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic + notebookAppendPage nb sw . Just =<< labelNew (Just labelString)) (zip (map fst pairList) widgets) - listStore <- listStoreNew (map fst pairList) - listView <- treeViewNewWithModel listStore + seqStore <- seqStoreNew (map fst pairList) + listView <- treeViewNewWithModel seqStore widgetSetSizeRequest listView 100 (-1) sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionSingle + treeSelectionSetMode sel SelectionModeSingle renderer <- cellRendererTextNew col <- treeViewColumnNew treeViewAppendColumn listView col cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore $ \row -> - [ cellText := row ] + cellLayoutSetCellDataFunc col renderer . Just $ \c r m i -> do + row <- customStoreGetRow seqStore i + setCellRendererTextText renderer row treeViewSetHeadersVisible listView False - treeSelectionSelectPath sel [0] + treeSelectionSelectPath sel =<< treePathNewFirst notebookSetCurrentPage nb 0 - on sel treeSelectionSelectionChanged (do - selections <- treeSelectionGetSelectedRows sel + onTreeSelectionChanged sel $ do + selections <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices' case selections of [[i]] -> notebookSetCurrentPage nb i - _ -> return ()) + _ -> return () - hb <- hBoxNew False 0 - sw <- scrolledWindowNew Nothing Nothing + grid <- gridNew + sw <- scrolledWindowNew noAdjustment noAdjustment containerAdd sw listView - scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic - boxPackStart hb sw PackNatural 0 - boxPackEnd hb nb PackGrow 7 + scrolledWindowSetPolicy sw PolicyTypeNever PolicyTypeAutomatic + widgetSetHalign sw AlignStart + widgetSetVexpand sw True + containerAdd grid sw + widgetSetHexpand nb True + widgetSetVexpand nb True + containerAdd grid nb let newInj v = mapM_ (\ setInj -> setInj v) setInjs let newExt v = extract v getExts mapM_ (propagateEvent notifier notifiers) allGUIEvents - return (castToWidget hb, newInj, newExt, notifier) + widget <- toWidget grid + return (widget, newInj, newExt, notifier) -buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha - -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) -buildBoxEditor descrs dir v = do +buildBoxEditor :: (Applicative m, MonadIO m) => [FieldDescription alpha] -> Orientation -> alpha + -> m (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildBoxEditor descrs orientation v = do resList <- mapM (`buildEditor` v) descrs notifier <- emptyNotifier let (widgets, setInjs, getExts, notifiers) = unzip4 resList - hb <- case dir of - Horizontal -> do - b <- hBoxNew False 0 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 0 - return (castToBox b) + grid <- gridNew + orientableSetOrientation grid orientation let newInj v = mapM_ (\ setInj -> setInj v) setInjs let fieldNames = map (fromMaybe "Unnamed" . getParameterPrim paraName . parameters) descrs let packParas = map (getParameter paraPack . parameters) descrs mapM_ (propagateEvent notifier notifiers) allGUIEvents let newExt v = extractAndValidate v getExts fieldNames notifier - mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas - return (castToWidget hb, newInj, newExt, notifier) + forM_ (zip widgets packParas) $ \(w, p) -> do + case p of + PackRepel -> setPrimaryAlign grid w AlignEnd >> setPrimaryExpand grid w True + PackNatural -> setPrimaryAlign grid w AlignStart + PackGrow -> setPrimaryExpand grid w True + setSecondaryExpand grid w True + containerAdd grid w + hbWidget <- liftIO $ toWidget grid + return (hbWidget, newInj, newExt, notifier) flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha] @@ -183,36 +242,33 @@ -- mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Editor alpha mkEditor injectorC extractor parameters notifier = do - let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters - outerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters - alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight - frame <- frameNew + frame <- frameNew Nothing + widgetSetHalign frame $ getParameter paraHAlign parameters + widgetSetValign frame $ getParameter paraVAlign parameters + let (top, bottom, start, end) = getParameter paraMargin parameters + widgetSetMarginTop frame top + widgetSetMarginBottom frame bottom + widgetSetMarginStart frame start + widgetSetMarginEnd frame end frameSetShadowType frame (getParameter paraShadow parameters) case getParameter paraName parameters of "" -> return () str -> when (getParameter paraShowLabel parameters) $ - frameSetLabel frame str - - containerAdd outerAlig frame - let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters - innerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters - alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight - containerAdd frame innerAlig + frameSetLabel frame (Just str) let (x,y) = getParameter paraMinSize parameters - widgetSetSizeRequest outerAlig x y + widgetSetSizeRequest frame x y let name = getParameter paraName parameters - widgetSetName outerAlig name - let build = injectorC (castToContainer innerAlig) - return (castToWidget outerAlig, build, extractor) + widgetSetName frame name + build <- injectorC <$> toContainer frame + w <- toWidget frame + return (w, build, extractor) -- | Convenience method to validate and extract fields -- -extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [Text] -> Notifier -> IO (Maybe alpha) +extractAndValidate :: MonadIO m => alpha -> [alpha -> Extractor alpha] -> [Text] -> Notifier -> m (Maybe alpha) extractAndValidate val getExts fieldNames notifier = do (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do - extVal <- ext val + extVal <- liftIO $ ext val case extVal of Just nval -> return (nval,errs) Nothing -> return (val, (" " <> fn) : errs)) @@ -220,31 +276,33 @@ if null errors then return (Just newVal) else do - triggerEvent notifier GUIEvent { + liftIO $ triggerEvent notifier GUIEvent { selector = ValidationError, eventText = mconcat (intersperse ", " errors), gtkReturn = True} return Nothing -extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) +extract :: MonadIO m => alpha -> [alpha -> Extractor alpha] -> m (Maybe alpha) extract val = foldM (\ mbVal ext -> case mbVal of Nothing -> return Nothing - Just val -> ext val) + Just val -> liftIO $ ext val) (Just val) -- | get through outerAlignment, frame, innerAlignment -getRealWidget :: Widget -> IO (Maybe Widget) -getRealWidget w = do - mbF <- binGetChild (castToBin w) - case mbF of +getRealWidget :: MonadIO m => Widget -> m (Maybe Widget) +getRealWidget w = liftIO $ ( + castTo Bin w >>= \case Nothing -> return Nothing - Just f -> do - mbIA <- binGetChild (castToBin f) - case mbIA of + Just b -> + (fromJust <$> nullToNothing (binGetChild b)) >>= castTo Bin >>= \case Nothing -> return Nothing - Just iA -> binGetChild (castToBin iA) + Just f -> + (fromJust <$> nullToNothing (binGetChild f)) >>= castTo Bin >>= \case + Nothing -> return Nothing + Just ia -> nullToNothing (binGetChild ia) + ) `catch` (\UnexpectedNullPointerReturn {} -> return Nothing) diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs --- a/src/Graphics/UI/Editor/Parameters.hs +++ b/src/Graphics/UI/Editor/Parameters.hs @@ -18,16 +18,13 @@ , Parameter(..) , paraName , paraSynopsis -, paraDirection +, paraOrientation , paraShowLabel , paraShadow -, paraOuterAlignment -, paraInnerAlignment -, paraOuterPadding -, paraInnerPadding +, paraMargin , paraMinSize -, paraHorizontal -, paraStockId +, paraHAlign +, paraVAlign , paraMultiSel , paraPack @@ -35,22 +32,58 @@ , getParameterPrim , (<<<-) , emptyParams -, Direction(..) -, HorizontalAlign(..) +, Packing(..) +, boxPackStart' +, boxPackEnd' +, dialogAddButton' +, dialogSetDefaultResponse' +, dialogResponse' +, dialogRun' ) where -import Graphics.UI.Gtk +import Prelude () +import Prelude.Compat import Data.Maybe import Data.Text (Text) import qualified Data.List as List +import GI.Gtk.Enums (Orientation(..), ResponseType, ShadowType(..)) +import GI.Gtk.Objects.Box (boxPackStart, IsBox, boxPackEnd) +import Control.Monad.IO.Class (MonadIO) +import GI.Gtk.Objects.Widget (Widget(..), IsWidget) +import Data.Word (Word32) +import Data.Int (Int32) +import qualified Data.Text as T (Text) +import GI.Gtk.Objects.Dialog + (dialogResponse, dialogSetDefaultResponse, IsDialog, dialogRun, + dialogAddButton) +import GI.Gtk.Structs.TreePath + (treePathNew, TreePath(..)) +import GI.Gtk (Orientation(..), Align(..)) +data Packing = PackRepel | PackGrow | PackNatural deriving (Eq, Show) --- --- | The direction of a split --- -data Direction = Horizontal | Vertical - deriving (Eq,Show) +boxPackStart' :: (MonadIO m, IsBox a, IsWidget b) => a -> b -> Packing -> Word32 -> m () +boxPackStart' a b PackRepel = boxPackStart a b True False +boxPackStart' a b PackGrow = boxPackStart a b True True +boxPackStart' a b PackNatural = boxPackStart a b False False +boxPackEnd' :: (MonadIO m, IsBox a, IsWidget b) => a -> b -> Packing -> Word32 -> m () +boxPackEnd' a b PackRepel = boxPackEnd a b True False +boxPackEnd' a b PackGrow = boxPackEnd a b True True +boxPackEnd' a b PackNatural = boxPackEnd a b False False + +dialogAddButton' :: (MonadIO m, IsDialog d) => d -> T.Text -> ResponseType -> m Widget +dialogAddButton' d t r = dialogAddButton d t (fromIntegral $ fromEnum r) + +dialogSetDefaultResponse' :: (MonadIO m, IsDialog d) => d -> ResponseType -> m () +dialogSetDefaultResponse' d r = dialogSetDefaultResponse d (fromIntegral $ fromEnum r) + +dialogResponse' :: (MonadIO m, IsDialog d) => d -> ResponseType -> m () +dialogResponse' d r = dialogResponse d (fromIntegral $ fromEnum r) + +dialogRun' :: (Applicative m, MonadIO m, IsDialog d) => d -> m ResponseType +dialogRun' d = toEnum . fromIntegral <$> dialogRun d + data HorizontalAlign = StartHorizontal | StopHorizontal | Keep deriving (Eq,Show) -- @@ -60,20 +93,14 @@ data Parameter = ParaName Text | ParaSynopsis Text - | ParaDirection Direction + | ParaOrientation Orientation | ParaShadow ShadowType | ParaShowLabel Bool - | ParaOuterAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaOuterPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaInnerAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaInnerPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaMinSize (Int, Int) - | ParaHorizontal HorizontalAlign - | ParaStockId Text + | ParaMargin (Int32,Int32,Int32,Int32) + -- ^ marginTop marginBottom marginLeft marginRight + | ParaMinSize (Int32, Int32) + | ParaHAlign Align + | ParaVAlign Align | ParaMultiSel Bool | ParaPack Packing deriving (Eq,Show) @@ -94,41 +121,29 @@ paraShowLabel (ParaShowLabel b) = Just b paraShowLabel _ = Nothing -paraDirection :: Parameter -> Maybe Direction -paraDirection (ParaDirection d) = Just d -paraDirection _ = Nothing +paraOrientation :: Parameter -> Maybe Orientation +paraOrientation (ParaOrientation d) = Just d +paraOrientation _ = Nothing paraShadow :: Parameter -> Maybe ShadowType paraShadow (ParaShadow d) = Just d paraShadow _ = Nothing -paraOuterAlignment :: Parameter -> Maybe (Float,Float,Float,Float) -paraOuterAlignment (ParaOuterAlignment d) = Just d -paraOuterAlignment _ = Nothing - -paraInnerAlignment :: Parameter -> Maybe (Float,Float,Float,Float) -paraInnerAlignment (ParaInnerAlignment d) = Just d -paraInnerAlignment _ = Nothing - -paraOuterPadding :: Parameter -> Maybe (Int,Int,Int,Int) -paraOuterPadding (ParaOuterPadding d) = Just d -paraOuterPadding _ = Nothing - -paraInnerPadding :: Parameter -> Maybe (Int,Int,Int,Int) -paraInnerPadding (ParaInnerPadding d) = Just d -paraInnerPadding _ = Nothing +paraMargin :: Parameter -> Maybe (Int32,Int32,Int32,Int32) +paraMargin (ParaMargin d) = Just d +paraMargin _ = Nothing -paraMinSize :: Parameter -> Maybe (Int, Int) +paraMinSize :: Parameter -> Maybe (Int32, Int32) paraMinSize (ParaMinSize d) = Just d paraMinSize _ = Nothing -paraHorizontal :: Parameter -> Maybe HorizontalAlign -paraHorizontal (ParaHorizontal d) = Just d -paraHorizontal _ = Nothing +paraHAlign :: Parameter -> Maybe Align +paraHAlign (ParaHAlign d) = Just d +paraHAlign _ = Nothing -paraStockId :: Parameter -> Maybe Text -paraStockId (ParaStockId str) = Just str -paraStockId _ = Nothing +paraVAlign :: Parameter -> Maybe Align +paraVAlign (ParaVAlign d) = Just d +paraVAlign _ = Nothing paraMultiSel :: Parameter -> Maybe Bool paraMultiSel (ParaMultiSel b) = Just b @@ -161,16 +176,13 @@ defaultParameters :: Parameters defaultParameters = [ ParaName "" - , ParaStockId "" , ParaSynopsis "" - , ParaDirection Horizontal - , ParaShadow ShadowNone - , ParaOuterAlignment (0.4, 0.5, 1.0, 0.7) - , ParaOuterPadding (5, 5, 5, 5) - , ParaInnerAlignment (0.4, 0.5, 1.0, 0.7) - , ParaInnerPadding (5, 5, 5, 5) - , ParaMinSize (-1,-1) - , ParaHorizontal Keep + , ParaOrientation OrientationHorizontal + , ParaShadow ShadowTypeNone + , ParaMargin (5, 5, 5, 5) + , ParaMinSize (-1,-1) + , ParaHAlign AlignFill + , ParaVAlign AlignFill , ParaMultiSel True , ParaPack PackNatural , ParaShowLabel True diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Simple @@ -39,38 +40,88 @@ , okCancelFields ) where -import Graphics.UI.Gtk -import Control.Monad +import Prelude () +import Prelude.Compat +import Control.Monad (void, (>=>), when, liftM) import Data.IORef -import Data.List +import Data.List (elemIndex) import Data.Maybe +import Data.Int (Int32) import System.FilePath.Posix +import Graphics.UI.Utils import Graphics.UI.Editor.Parameters --import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor import Control.Event import MyMissing (allOf) -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Graphics.UI.Editor.Basics (GUIEvent(..), GUIEventSelector(..), propagateAsChanged, genericGUIEvents, activateEvent, Editor) import Control.Exception as E (catch, IOException) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Applicative ((<$>)) import qualified Data.Text as T (strip, unpack, pack, empty) import Data.Monoid ((<>)) import Data.Text (Text) +import Data.GI.Base (new', GObject(..), unsafeCastTo, nullToNothing) +import GI.Gtk + (orientableSetOrientation, colorChooserGetRgba, + colorChooserSetRgba, widgetSetHalign, imageSetFromIconName, + imageNewFromIconName, noWidget, + gridNew, noAdjustment, setCellRendererToggleActive, RadioButton, + pattern STOCK_CANCEL, pattern STOCK_OK, colorButtonGetColor, colorButtonSetColor, + ColorButton(..), onColorButtonColorSet, colorButtonNew, + fontButtonGetFontName, fontButtonSetFontName, FontButton(..), + onFontButtonFontSet, fontButtonNew, widgetDestroy, + fileChooserGetFilename, dialogRun, widgetShow, + fileChooserSetAction, dialogAddButton, setWindowTitle, + FileChooserDialog(..), boxPackEnd, toBox, hBoxNew, + FileChooserAction, treeSelectionSelectPath, onWidgetKeyPressEvent, + onCellRendererToggleToggled, scrolledWindowSetMinContentHeight, + setCellRendererToggleActivatable, cellRendererToggleNew, + treeSelectionUnselectAll, constructDialogUseHeaderBar, + treeViewSetHeadersVisible, setCellRendererTextText, + cellLayoutPackStart, treeViewAppendColumn, treeViewColumnNew, + cellRendererTextNew, treeSelectionSetMode, treeViewGetSelection, + treeViewNewWithModel, Entry(..), binGetChild, + comboBoxTextNewWithEntry, comboBoxGetActive, comboBoxSetActive, + ComboBox(..), onComboBoxChanged, widgetSetSizeRequest, + spinButtonGetValue, spinButtonSetValue, SpinButton(..), + afterSpinButtonChangeValue, spinButtonNewWithRange, + textBufferGetText, textBufferGetEndIter, textBufferGetStartIter, + textBufferSetText, textViewGetBuffer, scrolledWindowSetPolicy, + scrolledWindowNew, textViewNew, entryGetText, entrySetText, + entryNew, imageSetFromStock, imageNewFromStock, + setWidgetCanDefault, widgetGrabDefault, buttonNewFromStock, + buttonNewWithLabel, widgetSetName, boxPackStart, + radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel, + vBoxNew, toggleButtonGetActive, toWidget, toggleButtonSetActive, + setWidgetName, checkButtonNewWithLabel, containerAdd, + onWidgetScrollEvent, comboBoxTextAppendText) +import GI.Gtk.Enums + (Orientation(..), Align(..), PositionType(..), ResponseType(..), + SelectionMode(..), PolicyType(..), IconSize(..)) +import Data.GI.Gtk.ComboBox + (comboBoxSetModelText, comboBoxAppendText, comboBoxNewText) +import Data.GI.Gtk.ModelView.CellLayout + (cellLayoutSetDataFunction) +import Data.GI.Gtk.ModelView.CustomStore + (CustomStore(..), customStoreGetRow) +import Data.GI.Gtk.ModelView.SeqStore + (SeqStore(..), seqStoreNew, seqStoreToList, seqStoreGetValue, + seqStoreAppend, seqStoreClear, seqStoreSetValue) +import Data.GI.Gtk.ModelView.Types + (treeSelectionGetSelectedRows', treePathGetIndices', + treePathNewFromIndices', stringToTreePath) +import GI.Gdk (keyvalName, getEventKeyKeyval, EventScroll) +import GI.GObject (objectNew, signalStopEmissionByName) +import Text.PrinterParser (Color(..), toGdkRGBA, fromGdkRGBA) -- ------------------------------------------------------------ -- * Simple Editors -- ------------------------------------------------------------ -instance ContainerClass Widget -instance BinClass Widget -instance ButtonClass Widget - -- -- | An invisible editor without any effect -- @@ -92,10 +143,10 @@ case core of Nothing -> do button <- checkButtonNewWithLabel (getParameter paraName parameters) - widgetSetName button (getParameter paraName parameters) + setWidgetName button (getParameter paraName parameters) containerAdd widget button toggleButtonSetActive button bool - mapM_ (activateEvent (castToWidget button) notifier Nothing) + mapM_ (activateEvent button notifier Nothing) (Clicked: genericGUIEvents) propagateAsChanged notifier [Clicked] writeIORef coreRef (Just button) @@ -120,19 +171,20 @@ core <- readIORef coreRef case core of Nothing -> do - box <- vBoxNew True 2 - radio1 <- radioButtonNewWithLabel (getParameter paraName parameters) - radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 - boxPackStart box radio1 PackGrow 2 - boxPackStart box radio2 PackGrow 2 + grid <- gridNew + orientableSetOrientation grid OrientationVertical + radio1 <- radioButtonNewWithLabel ([]::[RadioButton]) (getParameter paraName parameters) + radio2 <- radioButtonNewWithLabelFromWidget (Just radio1) label2 + containerAdd grid radio1 + containerAdd grid radio2 widgetSetName radio1 $ getParameter paraName parameters <> ".1" widgetSetName radio2 $ getParameter paraName parameters <> ".2" - containerAdd widget box + containerAdd widget grid if bool then toggleButtonSetActive radio1 True else toggleButtonSetActive radio2 True - mapM_ (activateEvent (castToWidget radio1) notifier Nothing) (Clicked:genericGUIEvents) - mapM_ (activateEvent (castToWidget radio2) notifier Nothing) (Clicked:genericGUIEvents) + mapM_ (activateEvent radio1 notifier Nothing) (Clicked:genericGUIEvents) + mapM_ (activateEvent radio2 notifier Nothing) (Clicked:genericGUIEvents) propagateAsChanged notifier [Clicked] writeIORef coreRef (Just (radio1,radio2)) Just (radio1,radio2) -> @@ -160,11 +212,12 @@ core <- readIORef coreRef case core of Nothing -> do - box <- vBoxNew True 2 + grid <- gridNew + orientableSetOrientation grid OrientationVertical let label0 = case labels ++ map (T.pack . show) vals of (x:_) -> x _ -> error "enumEditor" - button0 <- radioButtonNewWithLabel label0 + button0 <- radioButtonNewWithLabel ([]::[RadioButton]) label0 buttons <- mapM (\ v -> do let n = fromEnum v let label = case drop n labels of @@ -172,15 +225,15 @@ _ -> T.pack (show v) radio <- if n == 0 then return button0 - else radioButtonNewWithLabelFromWidget button0 label - boxPackStart box radio PackGrow 2 + else radioButtonNewWithLabelFromWidget (Just button0) label + containerAdd grid radio widgetSetName radio (label <> T.pack (show n)) return radio) vals - containerAdd widget box + containerAdd widget grid mapM_ (\e -> (mapM_ - (\b -> activateEvent (castToWidget b) notifier Nothing e) + (\b -> activateEvent b notifier Nothing e) buttons)) (Clicked:genericGUIEvents) propagateAsChanged notifier [Clicked] mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue)) @@ -212,15 +265,12 @@ core <- readIORef coreRef case core of Nothing -> do - button <- case getParameter paraStockId parameters of - "" -> buttonNewWithLabel (getParameter paraName parameters) - st -> buttonNewFromStock st - widgetSetName button (getParameter paraName parameters) + button <- buttonNewWithLabel (getParameter paraName parameters) containerAdd widget button - activateEvent (castToWidget button) notifier Nothing Clicked + activateEvent button notifier Nothing Clicked writeIORef coreRef (Just button) when canDefault $ do - set button [widgetCanDefault := True] + setWidgetCanDefault button True widgetGrabDefault button Just button -> return ()) (return (Just ())) @@ -229,7 +279,7 @@ -- | An Editor to display an image -- -imageEditor :: Editor StockId +imageEditor :: Editor Text imageEditor parameters notifier = do coreRef <- newIORef Nothing mkEditor @@ -237,11 +287,11 @@ core <- readIORef coreRef case core of Nothing -> do - image <- imageNewFromStock stockId IconSizeLargeToolbar + image <- imageNewFromIconName (Just stockId) (fromIntegral $ fromEnum IconSizeLargeToolbar) widgetSetName image (getParameter paraName parameters) containerAdd widget image writeIORef coreRef (Just (image,stockId)) - Just (image,stockId2) -> imageSetFromStock image stockId IconSizeLargeToolbar) + Just (image,stockId2) -> imageSetFromIconName image (Just stockId) (fromIntegral $ fromEnum IconSizeLargeToolbar)) (do core <- readIORef coreRef case core of Nothing -> return Nothing @@ -262,7 +312,7 @@ Nothing -> do entry <- entryNew widgetSetName entry (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents + mapM_ (activateEvent entry notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed] containerAdd widget entry entrySetText entry (if trimBlanks then T.strip string else string) @@ -300,18 +350,18 @@ Nothing -> do aTextView <- textViewNew widgetSetName aTextView (getParameter paraName parameters) - aScrolledWindow <- scrolledWindowNew Nothing Nothing - scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic + aScrolledWindow <- scrolledWindowNew noAdjustment noAdjustment + scrolledWindowSetPolicy aScrolledWindow PolicyTypeAutomatic PolicyTypeAutomatic containerAdd aScrolledWindow aTextView containerAdd widget aScrolledWindow - mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) genericGUIEvents + mapM_ (activateEvent aTextView notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed] buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string + textBufferSetText buffer string (-1) writeIORef coreRef (Just (aScrolledWindow,aTextView)) Just (aScrolledWindow,aTextView) -> do buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string) + textBufferSetText buffer string (-1)) (do core <- readIORef coreRef case core of Nothing -> return Nothing @@ -337,11 +387,12 @@ Nothing -> do spin <- spinButtonNewWithRange min max step widgetSetName spin (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget spin) notifier Nothing) genericGUIEvents - activateEvent (castToWidget spin) notifier - (Just (\ w h -> do - res <- afterValueSpinned (castToSpinButton w) (void h) - return (unsafeCoerce res))) MayHaveChanged + -- ignore scroll event, propagate to parent widget + onWidgetScrollEvent spin (\_ -> signalStopEmissionByName spin "scroll-event" >> return False) + mapM_ (activateEvent spin notifier Nothing) genericGUIEvents + activateEvent spin notifier + (Just (\ w h -> + afterSpinButtonChangeValue w (\_ -> void h))) MayHaveChanged containerAdd widget spin spinButtonSetValue spin (fromIntegral v) writeIORef coreRef (Just spin) @@ -386,7 +437,7 @@ button <- buttonNewWithLabel (getParameter paraName parameters) widgetSetName button (getParameter paraName parameters) containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) (Clicked:genericGUIEvents) + mapM_ (activateEvent button notifier Nothing) (Clicked:genericGUIEvents) writeIORef coreRef (Just button) Just button -> return ()) (return (Just ())) @@ -406,24 +457,26 @@ Nothing -> do combo <- comboBoxNewText widgetSetSizeRequest combo 200 (-1) + -- ignore scroll event, propagate to parent widget + onWidgetScrollEvent combo (\_ -> signalStopEmissionByName combo "scroll-event" >> return False) mapM_ (comboBoxAppendText combo . showF) list widgetSetName combo (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget combo) notifier Nothing) genericGUIEvents - activateEvent (castToWidget combo) notifier + mapM_ (activateEvent combo notifier Nothing) genericGUIEvents + activateEvent combo notifier (Just (\ w h -> do - res <- on (castToComboBox w) changed (void h) + res <- onComboBoxChanged w (void h) return (unsafeCoerce res))) MayHaveChanged comboBoxSetActive combo 1 containerAdd widget combo let ind = elemIndex obj list case ind of - Just i -> comboBoxSetActive combo i + Just i -> comboBoxSetActive combo (fromIntegral i) Nothing -> return () writeIORef coreRef (Just combo) Just combo -> do let ind = elemIndex obj list case ind of - Just i -> comboBoxSetActive combo i + Just i -> comboBoxSetActive combo (fromIntegral i) Nothing -> return ()) (do core <- readIORef coreRef case core of @@ -432,7 +485,7 @@ ind <- comboBoxGetActive combo case ind of (-1) -> return Nothing - otherwise -> return (Just (list !! ind))) + otherwise -> return (Just (list !! fromIntegral ind))) parameters notifier @@ -445,40 +498,34 @@ core <- readIORef coreRef case core of Nothing -> do - combo <- comboBoxNewWithEntry - comboBoxSetModelText combo + combo <- comboBoxTextNewWithEntry widgetSetSizeRequest combo 200 (-1) - mapM_ (comboBoxAppendText combo) list + mapM_ (comboBoxTextAppendText combo) list widgetSetName combo (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget combo) notifier Nothing) genericGUIEvents - activateEvent (castToWidget combo) notifier + mapM_ (activateEvent combo notifier Nothing) genericGUIEvents + activateEvent combo notifier (Just (\ w h -> do - res <- on (castToComboBox w) changed (void h) + res <- onComboBoxChanged w (void h) return (unsafeCoerce res))) MayHaveChanged - comboBoxSetActive combo 1 containerAdd widget combo let ind = elemIndex obj list case ind of - Just i -> comboBoxSetActive combo i + Just i -> comboBoxSetActive combo (fromIntegral i) Nothing -> do - mbEntry <- binGetChild combo - case mbEntry of - Nothing -> return () - Just entry -> entrySetText (castToEntry entry) obj + entry <- (fromJust <$> nullToNothing (binGetChild combo)) >>= unsafeCastTo Entry + entrySetText entry obj writeIORef coreRef (Just combo) Just combo -> do let ind = elemIndex obj list case ind of - Just i -> comboBoxSetActive combo i + Just i -> comboBoxSetActive combo (fromIntegral i) Nothing -> return ()) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just combo -> do - mbEntry <- binGetChild combo - case mbEntry of - Nothing -> return Nothing - Just entry -> Just <$> entryGetText (castToEntry entry)) + entry <- (fromJust <$> nullToNothing (binGetChild combo)) >>= unsafeCastTo Entry + Just <$> entryGetText entry) parameters notifier @@ -493,37 +540,37 @@ core <- readIORef coreRef case core of Nothing -> do - listStore <- listStoreNew ([]:: [alpha]) - listView <- treeViewNewWithModel listStore + seqStore <- seqStoreNew [] + listView <- treeViewNewWithModel seqStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + mapM_ (activateEvent listView notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionMultiple + treeSelectionSetMode sel SelectionModeMultiple renderer <- cellRendererTextNew col <- treeViewColumnNew treeViewAppendColumn listView col cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore - $ \row -> [ cellText := T.pack (show row) ] + cellLayoutSetDataFunction col renderer seqStore + (setCellRendererTextText renderer . T.pack . show) treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore) objs + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) objs containerAdd widget listView treeSelectionUnselectAll sel --let inds = catMaybes $map (\obj -> elemIndex obj list) objs --mapM_ (\i -> treeSelectionSelectPath sel [i]) inds - writeIORef coreRef (Just (listView,listStore)) - Just (listView,listStore) -> do - listStoreClear listStore - mapM_ (listStoreAppend listStore) objs) + writeIORef coreRef (Just (listView,seqStore)) + Just (listView,seqStore) -> do + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) objs) (do core <- readIORef coreRef case core of Nothing -> return Nothing - Just (listView,listStore) -> do + Just (listView,seqStore) -> do sel <- treeViewGetSelection listView - treePath <- treeSelectionGetSelectedRows sel - values <- mapM (\[i] -> listStoreGetValue listStore i) treePath + treePaths <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices' + values <- mapM (\[i] -> seqStoreGetValue seqStore (fromIntegral i)) treePaths return (Just values)) parameters notifier @@ -540,63 +587,63 @@ core <- readIORef coreRef case core of Nothing -> do - listStore <- listStoreNew ([]:: [(Bool,beta)]) - listView <- treeViewNewWithModel listStore + seqStore <- seqStoreNew ([]:: [(Bool,beta)]) + listView <- treeViewNewWithModel seqStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + mapM_ (activateEvent listView notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionSingle + treeSelectionSetMode sel SelectionModeSingle rendererToggle <- cellRendererToggleNew - set rendererToggle [cellToggleActivatable := True] + setCellRendererToggleActivatable rendererToggle True rendererText <- cellRendererTextNew col1 <- treeViewColumnNew treeViewAppendColumn listView col1 cellLayoutPackStart col1 rendererToggle True - cellLayoutSetAttributes col1 rendererToggle listStore - $ \row -> [ cellToggleActive := fst row] + cellLayoutSetDataFunction col1 rendererToggle seqStore + (setCellRendererToggleActive rendererToggle . fst) col2 <- treeViewColumnNew treeViewAppendColumn listView col2 cellLayoutPackStart col2 rendererText True - cellLayoutSetAttributes col2 rendererText listStore - $ \row -> [ cellText := showF (snd row)] + cellLayoutSetDataFunction col2 rendererText seqStore + (setCellRendererTextText rendererText . showF . snd) treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore . (\ e -> (e `elem` objs, e))) list + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore . (\ e -> (e `elem` objs, e))) list let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest listView) minSize - sw <- scrolledWindowNew Nothing Nothing + sw <- scrolledWindowNew noAdjustment noAdjustment containerAdd sw listView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic containerAdd widget sw scrolledWindowSetMinContentHeight sw (snd minSize) -- update the model when the toggle buttons are activated - on rendererToggle cellToggled $ \pathStr -> do + onCellRendererToggleToggled rendererToggle $ \pathStr -> do let (i:_) = stringToTreePath pathStr - val <- listStoreGetValue listStore i - listStoreSetValue listStore i (not (fst val),snd val) - listView `on` keyPressEvent $ do - name <- eventKeyName + val <- seqStoreGetValue seqStore i + seqStoreSetValue seqStore i (not (fst val),snd val) + onWidgetKeyPressEvent listView $ \e -> do + name <- getEventKeyKeyval e >>= keyvalName liftIO $ case name of - "Return" -> do + Just "Return" -> do sel <- treeViewGetSelection listView - rows <- treeSelectionGetSelectedRows sel + rows <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices' mapM_ (\ (i:_) -> do - val <- listStoreGetValue listStore i - listStoreSetValue listStore i (not (fst val),snd val)) rows + val <- seqStoreGetValue seqStore i + seqStoreSetValue seqStore i (not (fst val),snd val)) rows return True _ -> return False - writeIORef coreRef (Just (listView,listStore)) - Just (listView,listStore) -> do + writeIORef coreRef (Just (listView,seqStore)) + Just (listView,seqStore) -> do let model = map (\e -> (e `elem` objs,e)) list - listStoreClear listStore - mapM_ (listStoreAppend listStore . (\ e -> (e `elem` objs, e))) list) + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore . (\ e -> (e `elem` objs, e))) list) (do core <- readIORef coreRef case core of Nothing -> return Nothing - Just (listView,listStore) -> do - model <- listStoreToList listStore + Just (listView,seqStore) -> do + model <- seqStoreToList seqStore return (Just (map snd $ filter fst model))) parameters notifier @@ -613,37 +660,37 @@ core <- readIORef coreRef case core of Nothing -> do - listStore <- listStoreNew ([]:: [alpha]) - listView <- treeViewNewWithModel listStore + seqStore <- seqStoreNew ([]:: [alpha]) + listView <- treeViewNewWithModel seqStore widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) genericGUIEvents + mapM_ (activateEvent listView notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] sel <- treeViewGetSelection listView treeSelectionSetMode sel (if getParameter paraMultiSel parameters - then SelectionMultiple - else SelectionSingle) + then SelectionModeMultiple + else SelectionModeSingle) renderer <- cellRendererTextNew col <- treeViewColumnNew treeViewAppendColumn listView col cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore - $ \row -> [ cellText := showF row ] + cellLayoutSetDataFunction col renderer seqStore + (setCellRendererTextText renderer . showF) treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore) list + seqStoreClear seqStore + mapM_ (seqStoreAppend seqStore) list let minSize = getParameter paraMinSize parameters uncurry (widgetSetSizeRequest listView) minSize - sw <- scrolledWindowNew Nothing Nothing + sw <- scrolledWindowNew noAdjustment noAdjustment containerAdd sw listView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic containerAdd widget sw scrolledWindowSetMinContentHeight sw (snd minSize) treeSelectionUnselectAll sel let mbInd = elemIndex obj list case mbInd of Nothing -> return () - Just ind -> treeSelectionSelectPath sel [ind] + Just ind -> treeSelectionSelectPath sel =<< treePathNewFromIndices' [fromIntegral ind] writeIORef coreRef (Just listView) Just listView -> do sel <- treeViewGetSelection listView @@ -651,15 +698,15 @@ let mbInd = elemIndex obj list case mbInd of Nothing -> return () - Just ind -> treeSelectionSelectPath sel [ind]) + Just ind -> treeSelectionSelectPath sel =<< treePathNewFromIndices' [fromIntegral ind]) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just listView -> do sel <- treeViewGetSelection listView - treePaths <- treeSelectionGetSelectedRows sel + treePaths <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices' case treePaths of - [[i]] -> return (Just (list !! i)) + [[i]] -> return (Just (list !! fromIntegral i)) _ -> return Nothing) parameters notifier @@ -678,24 +725,20 @@ Nothing -> do button <- buttonNewWithLabel buttonName widgetSetName button $ getParameter paraName parameters <> "-button" - mapM_ (activateEvent (castToWidget button) notifier Nothing) + mapM_ (activateEvent button notifier Nothing) (Clicked:genericGUIEvents) - entry <- entryNew + entry <- entryNew widgetSetName entry $ getParameter paraName parameters <> "-entry" -- set entry [ entryEditable := False ] - mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents + mapM_ (activateEvent entry notifier Nothing) genericGUIEvents registerEvent notifier Clicked (buttonHandler entry) propagateAsChanged notifier [KeyPressed,ButtonPressed] - box <- case getParameter paraDirection parameters of - Horizontal -> do - r <- hBoxNew False 1 - return (castToBox r) - Vertical -> do - r <- vBoxNew False 1 - return (castToBox r) - boxPackStart box entry PackGrow 0 - boxPackEnd box button PackNatural 0 - containerAdd widget box + grid <- gridNew + orientableSetOrientation grid (getParameter paraOrientation parameters) + widgetSetHalign button AlignEnd + containerAdd grid entry + containerAdd grid button + containerAdd widget grid entrySetText entry (T.pack filePath) writeIORef coreRef (Just entry) Just entry -> entrySetText entry (T.pack filePath)) @@ -710,25 +753,22 @@ where buttonHandler entry e = do mbFileName <- do - dialog <- fileChooserDialogNew - (Just ("Select File"::Text)) - Nothing - action - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] + dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1] + setWindowTitle dialog "Select File" + dialogAddButton dialog "gtk-cancel" (fromIntegral $ fromEnum ResponseTypeCancel) + dialogAddButton dialog "gtk-open" (fromIntegral $ fromEnum ResponseTypeAccept) + fileChooserSetAction dialog action widgetShow dialog response <- dialogRun dialog - case response of - ResponseAccept -> do + case toEnum $ fromIntegral response of + ResponseTypeAccept -> do f <- fileChooserGetFilename dialog widgetDestroy dialog return f - ResponseCancel -> do + ResponseTypeCancel -> do widgetDestroy dialog return Nothing - ResponseDeleteEvent-> do + ResponseTypeDeleteEvent-> do widgetDestroy dialog return Nothing _ -> return Nothing @@ -758,10 +798,10 @@ Nothing -> do fs <- fontButtonNew widgetSetName fs $ getParameter paraName parameters - mapM_ (activateEvent (castToWidget fs) notifier Nothing) (Clicked: genericGUIEvents) - activateEvent (castToWidget fs) notifier + mapM_ (activateEvent fs notifier Nothing) (Clicked: genericGUIEvents) + activateEvent fs notifier (Just (\ w h -> do - res <- onFontSet (castToFontButton w) (void h) + res <- onFontButtonFontSet w (void h) return (unsafeCoerce res))) MayHaveChanged containerAdd widget fs case mbValue of @@ -795,20 +835,20 @@ Nothing -> do cs <- colorButtonNew widgetSetName cs $ getParameter paraName parameters - mapM_ (activateEvent (castToWidget cs) notifier Nothing) (Clicked: genericGUIEvents) - activateEvent (castToWidget cs) notifier + mapM_ (activateEvent cs notifier Nothing) (Clicked: genericGUIEvents) + activateEvent cs notifier (Just (\ w h -> do - res <- onColorSet (castToColorButton w) (void h) + res <- onColorButtonColorSet w (void h) return (unsafeCoerce res))) MayHaveChanged containerAdd widget cs - colorButtonSetColor cs c + colorChooserSetRgba cs =<< toGdkRGBA c writeIORef coreRef (Just cs) - Just cs -> colorButtonSetColor cs c) + Just cs -> colorChooserSetRgba cs =<< toGdkRGBA c) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just cs -> do - c <- colorButtonGetColor cs + c <- colorChooserGetRgba cs >>= fromGdkRGBA return (Just c)) parameters notifier @@ -828,7 +868,7 @@ button <- buttonNewWithLabel (getParameter paraName parameters) widgetSetName button $ getParameter paraName parameters containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) (Clicked:genericGUIEvents) + mapM_ (activateEvent button notifier Nothing) (Clicked:genericGUIEvents) registerEvent notifier Clicked (buttonHandler coreRef) propagateAsChanged notifier [KeyPressed,ButtonPressed,Clicked] writeIORef coreRef (Just (button,val)) @@ -855,17 +895,14 @@ okCancelFields :: FieldDescription () okCancelFields = HFD emptyParams [ mkField - (paraStockId <<<- ParaStockId stockCancel - $ paraName <<<- ParaName "Cancel" - $ emptyParams) + (paraName <<<- ParaName "Cancel" + $ emptyParams) (const ()) (\ _ b -> b) (clickEditor False) , mkField - (paraStockId <<<- ParaStockId stockOk - $ paraName <<<- ParaName "Ok" - $ emptyParams) + (paraName <<<- ParaName "Ok" + $ emptyParams) (const ()) (\ a b -> b) (clickEditor True)] - diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs --- a/src/Graphics/UI/Frame/Panes.hs +++ b/src/Graphics/UI/Frame/Panes.hs @@ -35,19 +35,27 @@ , signalDisconnectAll ) where -import Graphics.UI.Gtk hiding (get) -import System.Glib.GObject -import System.Glib.Signals +import Prelude () +import Prelude.Compat +import Control.Applicative (Applicative) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import Data.Typeable import Graphics.UI.Editor.Basics (Connection(..), Connection, Connections) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO(..), MonadIO) import Data.Text (Text) import Data.Monoid ((<>)) import qualified Data.Text as T (pack) +import Data.GI.Base.ManagedPtr (unsafeCastTo) +import GI.Gtk.Objects.Widget (Widget(..)) +import GI.Gtk.Objects.Notebook (Notebook(..)) +import GI.Gtk.Objects.Window (Window(..)) +import GI.Gtk.Objects.UIManager (UIManager(..)) +import GI.GObject.Functions (signalHandlerDisconnect) +import GI.GObject.Objects.Object (Object(..)) +import Foreign.Ptr (Ptr) -- --------------------------------------------------------------------- -- Panes and pane layout @@ -90,7 +98,7 @@ class (Typeable alpha, PaneMonad delta) => Pane alpha delta | alpha -> delta where - getTopWidget :: alpha -> Widget + getTopWidget :: alpha -> delta Widget -- ^ gets the top Widget of this pane paneId :: alpha -> Text primPaneName :: alpha -> Text @@ -98,8 +106,11 @@ paneName :: alpha -> PaneName paneName b = if getAddedIndex b == 0 then primPaneName b - else primPaneName b <> "(" <> T.pack (show $ getAddedIndex b) <> ")" + else primPaneName b <> " (" <> T.pack (show $ getAddedIndex b) <> ")" + paneTooltipText :: alpha -> Maybe Text + paneTooltipText p = Nothing + getAddedIndex :: alpha -> Int getAddedIndex _ = 0 @@ -151,7 +162,7 @@ -class MonadIO delta => PaneMonad delta where +class (Applicative delta, MonadIO delta) => PaneMonad delta where setFrameState :: FrameState delta -> delta () getFrameState :: delta (FrameState delta) runInIO :: forall alpha beta. (beta -> delta alpha) -> delta (beta -> IO alpha) @@ -190,7 +201,7 @@ , panes :: Map PaneName (IDEPane delta) , paneMap :: Map PaneName (PanePath, Connections) , activePane :: Maybe (PaneName, Connections) -, panePathFromNB :: ! (Map Notebook PanePath) +, panePathFromNB :: ! (Map (Ptr Notebook) PanePath) , layout :: PaneLayout} deriving Show @@ -206,6 +217,6 @@ instance Show Notebook where show _ = "a Notebook" -signalDisconnectAll :: Connections -> IO () -signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) +signalDisconnectAll :: MonadIO m => Connections -> m () +signalDisconnectAll = mapM_ (\ (ConnectC o s) -> liftIO (unsafeCastTo Object o) >>= flip signalHandlerDisconnect s) diff --git a/src/Graphics/UI/Frame/Rectangle.hs b/src/Graphics/UI/Frame/Rectangle.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Frame/Rectangle.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.ViewFrame +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- +-- | Portable Rectangle type that works with older Gdk versions +-- +--------------------------------------------------------------------------------- + +module Graphics.UI.Frame.Rectangle ( + Rectangle(..) +, newRectangle +, setRectangleWidth +, setRectangleHeight +, setRectangleX +, setRectangleY +, getRectangleWidth +, getRectangleHeight +, getRectangleX +, getRectangleY +) where + +import Data.Int (Int32) +import Data.GI.Base (new, AttrOp) +import Data.GI.Base.Attributes (AttrOpTag(..)) +import Control.Monad.IO.Class (MonadIO) +#ifdef MIN_VERSION_GDK_3_18 +import GI.Gdk (Rectangle(..), getRectangleWidth, getRectangleHeight, getRectangleX, getRectangleY, + setRectangleWidth, setRectangleHeight, setRectangleX, setRectangleY) +#else +import GI.Cairo (RectangleInt(..), getRectangleIntWidth, getRectangleIntHeight, getRectangleIntX, getRectangleIntY, + setRectangleIntWidth, setRectangleIntHeight, setRectangleIntX, setRectangleIntY) +#endif + +#ifdef MIN_VERSION_GDK_3_18 +rectangle = Rectangle +#else +type Rectangle = RectangleInt +rectangle = RectangleInt +getRectangleWidth, getRectangleHeight, getRectangleX, getRectangleY :: MonadIO m => Rectangle -> m Int32 +getRectangleWidth = getRectangleIntWidth +getRectangleHeight = getRectangleIntHeight +getRectangleX = getRectangleIntX +getRectangleY = getRectangleIntY +setRectangleWidth, setRectangleHeight, setRectangleX, setRectangleY :: MonadIO m => Rectangle -> Int32 -> m () +setRectangleWidth = setRectangleIntWidth +setRectangleHeight = setRectangleIntHeight +setRectangleX = setRectangleIntX +setRectangleY = setRectangleIntY +#endif + +newRectangle :: MonadIO m => Int32 -> Int32 -> Int32 -> Int32 -> m Rectangle +newRectangle x y width height = do + r <- new rectangle [] + setRectangleX r x + setRectangleY r y + setRectangleWidth r width + setRectangleHeight r height + return r diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,6 +9,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.ViewFrame @@ -94,43 +99,11 @@ , initGtkRc ) where -import Graphics.UI.Gtk - (castToNotebook, uiManagerGetAction, Action, Paned, - selectionDataGetText, SelectionDataM, InfoId, Point, DragContext, - dragDataReceived, dragDestSetTargetList, dragDestSet, - notebookSetPopup, notebookSetScrollable, notebookNew, - windowPresent, widgetVisible, notebookRemovePage, Notebook, - windowGetScreen, Screen, castToWindow, gTypeWindow, - widgetGetToplevel, deleteEvent, widgetGetAllocation, - windowSetDefaultSize, widgetName, windowNew, Widget, - dialogResponse, dialogGetActionArea, castToHBox, - dialogGetContentArea, windowTitle, windowTransientFor, dialogNew, - Window, widgetDestroy, dialogRun, messageDialogNew, castToWidget, - switchPage, widgetGrabFocus, castToVBox, boxReorderChild, - castToBox, notebookSetMenuLabel, notebookSetTabLabel, - notebookInsertPage, panedPack1, castToContainer, containerRemove, - notebookPageNum, panedPack2, hPanedNew, castToPaned, vPanedNew, - widgetGetParent, notebookGetCurrentPage, notebookSetTabPos, - PositionType, notebookSetShowTabs, notebookGetShowTabs, - castToLabel, containerGetChildren, castToBin, binGetChild, - notebookGetTabLabel, labelSetMarkup, labelSetUseMarkup, - buttonActivated, selectionDataSetText, dragDataGet, - dragSourceSetTargetList, targetListAddTextTargets, targetListNew, - dragSourceSet, boxPackStart, containerAdd, containerSetBorderWidth, - widgetSetVAlign, widgetGetStyleContext, stockClose, - imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon, - iconThemeGetDefault, buttonSetAlignment, buttonSetRelief, - buttonSetFocusOnClick, buttonNew, hBoxNew, - eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding, castToMisc, - miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll, - notebookInsertPageMenu, widgetGetName, notebookGetNthPage, - notebookGetNPages, labelNew, Label, WidgetClass, NotebookClass, - widgetSetName, IconSize(..), ResponseId(..), Rectangle(..), - DragAction(..), DestDefaults(..), PositionType(..), Packing(..), - ReliefStyle(..), IconLookupFlags(..), after, on, ButtonsType(..), - MessageType(..), AttrOp(..), get, set) +import Prelude () +import Prelude.Compat +import Control.Applicative (Applicative) import qualified Data.Map as Map -import Data.List +import Data.List (findIndex, isPrefixOf, deleteBy, stripPrefix, elemIndex) import Data.Maybe import Data.Unique import Data.Typeable @@ -138,37 +111,93 @@ import Graphics.UI.Frame.Panes import Graphics.UI.Editor.Parameters -import System.Glib (GObjectClass(..), isA) -import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) import System.CPUTime (getCPUTime) -import Graphics.UI.Gtk.Gdk.EventM - (Modifier(..), eventModifierMouse, TimeStamp(..)) -import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) -import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) -import Graphics.UI.Gtk.General.Enums (Align(..)) import MyMissing (forceJust, forceHead) import Graphics.UI.Editor.MakeEditor (mkField, FieldDescription(..), buildEditor) -import Graphics.UI.Editor.Simple (stringEditor, textEditor, okCancelFields) +import Graphics.UI.Editor.Simple (stringEditor, textEditor) import Control.Event (registerEvent) import Graphics.UI.Editor.Basics (eventText, GUIEventSelector(..)) import qualified Data.Set as Set (unions, member) import Data.Set (Set(..)) -import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (when, liftM, foldM) +import Control.Monad (unless, when, liftM, foldM) import Control.Applicative ((<$>)) import qualified Control.Monad.Reader as Gtk (liftIO) import qualified Data.Text as T (pack, stripPrefix, unpack) import Data.Monoid ((<>)) -import Graphics.UI.Gtk.Abstract.Widget - (widgetSetHAlign, widgetSetSizeRequest, buttonReleaseEvent) import Data.Foldable (forM_) import Control.Arrow (Arrow(..)) +import GI.Gtk + (panedNew, gridNew, widgetSetValign, widgetSetHalign, noWidget, + windowGetScreen, Bin(..), CssProvider(..), uIManagerGetAction, + Action, toWidget, selectionDataGetText, SelectionData, + WidgetDragDataReceivedCallback, onWidgetDragDataReceived, + widgetDragDestSetTargetList, widgetDragDestSet, + setNotebookEnablePopup, notebookSetScrollable, + widgetSetSizeRequest, notebookNew, windowPresent, getWidgetVisible, + notebookRemovePage, Window(..), widgetGetToplevel, + onWidgetDeleteEvent, widgetGetAllocation, windowSetDefaultSize, + setWidgetName, windowNew, Widget(..), dialogResponse, + dialogGetContentArea, setWindowTitle, setWindowTransientFor, + dialogNew, Window, windowSetTransientFor, setMessageDialogText, + constructDialogUseHeaderBar, MessageDialog(..), widgetDestroy, + dialogRun, afterNotebookSwitchPage, widgetGrabFocus, + boxReorderChild, Box(..), notebookSetMenuLabel, + notebookSetTabLabel, notebookInsertPage, Paned(..), panedPack1, + containerRemove, notebookPageNum, Notebook(..), panedPack2, + hPanedNew, toPaned, Container(..), vPanedNew, widgetGetParent, + notebookGetCurrentPage, notebookSetTabPos, PositionType(..), + notebookSetShowTabs, notebookGetShowTabs, Label(..), + containerGetChildren, binGetChild, notebookGetTabLabel, + labelSetMarkup, labelSetUseMarkup, onWidgetButtonReleaseEvent, + onButtonClicked, selectionDataSetText, onWidgetDragDataGet, + widgetDragSourceSetTargetList, targetListAddTextTargets, + targetListNew, widgetDragSourceSet, setWidgetHalign, + setWidgetValign, cssProviderLoadFromData, boxPackStart, + containerAdd, containerSetBorderWidth, styleContextAddProvider, + widgetGetStyleContext, cssProviderNew, pattern STOCK_CLOSE, + imageNewFromStock, imageNewFromPixbuf, iconThemeLoadIcon, + iconThemeGetDefault, buttonSetAlignment, buttonSetRelief, + buttonSetFocusOnClick, buttonNew, hBoxNew, + eventBoxSetVisibleWindow, eventBoxNew, miscSetPadding, + miscSetAlignment, EventBox, notebookSetCurrentPage, widgetShowAll, + notebookInsertPageMenu, widgetGetName, notebookGetNthPage, + notebookGetNPages, labelNew, Label, IsWidget, IsNotebook, + widgetSetName) +#ifdef MIN_VERSION_GTK_3_20 +import GI.Gtk.Objects.Widget (widgetSetFocusOnClick) +#else +import GI.Gtk.Objects.Button (buttonSetFocusOnClick) +#endif +import GI.Gtk.Enums + (Orientation(..), WindowType(..), ResponseType(..), + ButtonsType(..), MessageType(..), PositionType(..), Align(..), + IconSize(..), ReliefStyle(..)) +import GI.Gtk.Flags (DestDefaults(..), IconLookupFlags(..)) +import GI.Gdk.Flags (ModifierType(..), DragAction(..)) +import GI.Gdk + (DragContext, Screen, getEventButtonState) +import Graphics.UI.Frame.Rectangle (getRectangleWidth, getRectangleHeight) +import Data.GI.Base + (unsafeManagedPtrCastPtr, withManagedPtr, castTo, unsafeCastTo, + ManagedPtrNewtype, UnexpectedNullPointerReturn(..), GObject(..), + new', nullToNothing) +import Control.Exception (catch) +import Data.Int (Int32) +import Data.Word (Word32) +import Data.Function (on) +import Data.Coerce (coerce) +import Data.GI.Gtk.ModelView.Types (equalManagedPtr) +import GI.Gtk.Objects.Dialog (Dialog(..), constructDialogUseHeaderBar) +import GI.Gtk.Objects.MessageDialog + (constructMessageDialogButtons, setMessageDialogMessageType) +import GI.Gtk.Objects.Label (noLabel) +import GI.Gtk.Objects.Widget (widgetSetTooltipText) ---import Debug.Trace (trace) -trace (a::Text) b = b +-- import Debug.Trace (trace) +trace (a::String) b = b groupPrefix = "_group_" @@ -190,7 +219,8 @@ addPaneAdmin pane conn pp = do panes' <- getPanesSt paneMap' <- getPaneMapSt - liftIO $ widgetSetName (getTopWidget pane) (paneName pane) + topWidget <- getTopWidget pane + widgetSetName topWidget (paneName pane) let b1 = case Map.lookup (paneName pane) paneMap' of Nothing -> True Just it -> False @@ -204,7 +234,7 @@ return True else trace ("ViewFrame>addPaneAdmin:pane with this name already exist" <> - paneName pane) + T.unpack (paneName pane)) $ return False getPanePrim :: RecoverablePane alpha beta delta => delta (Maybe alpha) @@ -219,102 +249,98 @@ panes' <- getPanesSt return (mapMaybe (\ (PaneC p) -> cast p) (Map.elems panes')) -notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) +notebookInsertOrdered :: PaneMonad alpha => (IsNotebook self, IsWidget child) => self -> child -- child - the Widget to use as the contents of the page. -> Text -> Maybe Label -- the label for the page as Text or Label + -> Maybe Text -- ^ Text for tooltip when hovering -> Bool -> alpha () -notebookInsertOrdered nb widget labelStr mbLabel isGroup = do +notebookInsertOrdered nb widget labelStr mbLabel mbTooltipText isGroup = do label <- case mbLabel of - Nothing -> liftIO $ labelNew (Just labelStr) + Nothing -> labelNew (Just labelStr) Just l -> return l - menuLabel <- liftIO $ labelNew (Just labelStr) - numPages <- liftIO $ notebookGetNPages nb - mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)] + menuLabel <- labelNew (Just labelStr) + numPages <- notebookGetNPages nb + mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)] let widgets = map (`forceJust` "ViewFrame.notebookInsertOrdered: no widget") mbWidgets - labelStrs <- liftIO $ mapM widgetGetName widgets + labelStrs <- mapM widgetGetName widgets let pos = fromMaybe (-1) (findIndex (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr) labelStrs) labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr - liftIO $ do - markLabel nb labelBox False - realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos - widgetShowAll labelBox - notebookSetCurrentPage nb realPos + realPos <- notebookInsertPageMenu nb widget (Just labelBox) (Just menuLabel) (fromIntegral pos) + widgetSetTooltipText labelBox mbTooltipText + widgetShowAll labelBox + notebookSetCurrentPage nb realPos -- | Returns a label box mkLabelBox :: PaneMonad alpha => Label -> Text -> alpha EventBox mkLabelBox lbl paneName = do - (tb,lb) <- liftIO $ do - miscSetAlignment (castToMisc lbl) 0.0 0.0 - miscSetPadding (castToMisc lbl) 0 0 + widgetSetHalign lbl AlignStart + widgetSetValign lbl AlignStart - labelBox <- eventBoxNew - eventBoxSetVisibleWindow labelBox False - innerBox <- hBoxNew False 0 + labelBox <- eventBoxNew + eventBoxSetVisibleWindow labelBox False + innerBox <- gridNew - tabButton <- buttonNew - widgetSetName tabButton ("leksah-close-button"::Text) - buttonSetFocusOnClick tabButton False - buttonSetRelief tabButton ReliefNone - buttonSetAlignment tabButton (0.0,0.0) + tabButton <- buttonNew + widgetSetName tabButton "leksah-close-button" +#ifdef MIN_VERSION_GTK_3_20 + widgetSetFocusOnClick tabButton False +#else + buttonSetFocusOnClick tabButton False +#endif + buttonSetRelief tabButton ReliefStyleNone + widgetSetHalign tabButton AlignEnd + widgetSetValign tabButton AlignCenter - iconTheme <- iconThemeGetDefault - mbIcon <- iconThemeLoadIcon iconTheme ("window-close"::Text) 10 IconLookupUseBuiltin - image <- case mbIcon of - Just i -> imageNewFromPixbuf i - Nothing -> imageNewFromStock stockClose IconSizeMenu + iconTheme <- iconThemeGetDefault + image <- iconThemeLoadIcon iconTheme "window-close" 10 [IconLookupFlagsUseBuiltin] >>= imageNewFromPixbuf - provider <- cssProviderNew - cssProviderLoadFromString provider ( - ".button {\n" <> - "-GtkButton-default-border : 0px;\n" <> - "-GtkButton-default-outside-border : 0px;\n" <> - "-GtkButton-inner-border: 0px;\n" <> - "-GtkWidget-focus-line-width : 0px;\n" <> - "-GtkWidget-focus-padding : 0px;\n" <> - "padding: 0px;\n" <> - "border-width: 0px;\n" <> - "}\n" <> - "GtkImage {\n" <> - "padding: 0px;\n" <> - "}\n" :: Text) - context <- widgetGetStyleContext tabButton - styleContextAddProvider context provider 600 - context <- widgetGetStyleContext image - styleContextAddProvider context provider 600 - widgetSetVAlign tabButton AlignCenter - widgetSetVAlign lbl AlignCenter + provider <- cssProviderNew + cssProviderLoadFromData provider ( + ".button {\n" <> + "padding: 0px;\n" <> + "border-width: 0px;\n" <> + "}\n" <> + "GtkImage {\n" <> + "padding: 0px;\n" <> + "}\n") + context <- widgetGetStyleContext tabButton + styleContextAddProvider context provider 600 + context <- widgetGetStyleContext image + styleContextAddProvider context provider 600 + setWidgetValign tabButton AlignCenter + setWidgetValign lbl AlignCenter - containerSetBorderWidth tabButton 0 - containerAdd tabButton image + containerSetBorderWidth tabButton 0 + containerAdd tabButton image - boxPackStart innerBox lbl PackNatural 0 - boxPackStart innerBox tabButton PackNatural 0 + containerAdd innerBox lbl + containerAdd innerBox tabButton - containerAdd labelBox innerBox - widgetSetHAlign innerBox AlignCenter - dragSourceSet labelBox [Button1] [ActionCopy,ActionMove] - tl <- targetListNew - targetListAddTextTargets tl 0 - dragSourceSetTargetList labelBox tl - on labelBox dragDataGet (\ cont id timeStamp -> do - selectionDataSetText paneName - return ()) - return (tabButton,labelBox) + containerAdd labelBox innerBox + setWidgetHalign innerBox AlignCenter + widgetDragSourceSet labelBox [ModifierTypeButton1Mask] Nothing [DragActionCopy,DragActionMove] + tl <- targetListNew Nothing + targetListAddTextTargets tl 0 + widgetDragSourceSetTargetList labelBox $ Just tl + onWidgetDragDataGet labelBox (\ cont sel id timeStamp -> do + trace ("drag paneName=" <> T.unpack paneName) $ return () + selectionDataSetText sel paneName (-1) + return ()) cl <- runInIO closeHandler - liftIO $ on tb buttonActivated (cl ()) - liftIO $ on lb buttonReleaseEvent $ do - modifiers <- eventModifierMouse - let middleButton = Button2 - when (middleButton `elem` modifiers) (liftIO $ cl ()) + onButtonClicked tabButton (cl ()) + onWidgetButtonReleaseEvent labelBox $ \e -> do + modifiers <- getEventButtonState e + let middleButton = ModifierTypeButton2Mask + when (middleButton `elem` modifiers) (cl ()) return False - return lb + return labelBox where closeHandler :: PaneMonad alpha => () -> alpha () closeHandler _ = case groupPrefix `T.stripPrefix` paneName of @@ -326,32 +352,29 @@ groupLabel :: PaneMonad beta => Text -> beta EventBox groupLabel group = do - label <- liftIO $ labelNew (Nothing::Maybe Text) - liftIO $ labelSetUseMarkup label True - liftIO $ labelSetMarkup label ("" <> group <> "") + label <- labelNew Nothing + labelSetUseMarkup label True + labelSetMarkup label ("" <> group <> "") labelBox <- mkLabelBox label (groupPrefix <> group) - liftIO $ widgetShowAll labelBox + widgetShowAll labelBox return labelBox -- | Add the change mark or removes it -markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () -markLabel nb topWidget modified = do - mbBox <- notebookGetTabLabel nb topWidget - case mbBox of +markLabel :: (MonadIO m, IsWidget alpha, IsNotebook beta) => beta -> alpha -> Bool -> m () +markLabel nb topWidget modified = + notebookGetTabLabel nb topWidget >>= \case Nothing -> return () - Just box -> do - mbContainer <- binGetChild (castToBin box) - case mbContainer of - Nothing -> return () - Just container -> do - children <- containerGetChildren container - let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" - (text :: Text) <- widgetGetName topWidget - labelSetUseMarkup (castToLabel label) True - labelSetMarkup (castToLabel label) - (if modified - then "" <> text <> "" - else text) + Just box -> liftIO (unsafeCastTo Bin box) >>= nullToNothing . binGetChild >>= \case + Nothing -> return () + Just container -> do + children <- liftIO (unsafeCastTo Container container) >>= containerGetChildren + label <- liftIO . unsafeCastTo Label $ forceHead (tail children) "ViewFrame>>markLabel: empty children" + text <- widgetGetName topWidget + labelSetUseMarkup label True + labelSetMarkup label + (if modified + then "" <> text <> "" + else text) -- | Constructs a unique pane name, which is an index and a string figureOutPaneName :: PaneMonad alpha => Text -> Int -> alpha (Int,Text) @@ -386,15 +409,15 @@ Just it -> return it otherwise -> error $"Cant't find guiProperties from unique name " ++ T.unpack pn -posTypeToPaneDirection PosLeft = LeftP -posTypeToPaneDirection PosRight = RightP -posTypeToPaneDirection PosTop = TopP -posTypeToPaneDirection PosBottom = BottomP +posTypeToPaneDirection PositionTypeLeft = LeftP +posTypeToPaneDirection PositionTypeRight = RightP +posTypeToPaneDirection PositionTypeTop = TopP +posTypeToPaneDirection PositionTypeBottom = BottomP -paneDirectionToPosType LeftP = PosLeft -paneDirectionToPosType RightP = PosRight -paneDirectionToPosType TopP = PosTop -paneDirectionToPosType BottomP = PosBottom +paneDirectionToPosType LeftP = PositionTypeLeft +paneDirectionToPosType RightP = PositionTypeRight +paneDirectionToPosType TopP = PositionTypeTop +paneDirectionToPosType BottomP = PositionTypeBottom -- -- | Toggle the tabs of the current notebook @@ -404,7 +427,7 @@ mbNb <- getActiveNotebook case mbNb of Nothing -> return () - Just nb -> liftIO $ do + Just nb -> do b <- notebookGetShowTabs nb notebookSetShowTabs nb (not b) @@ -416,117 +439,108 @@ mbNb <- getActiveNotebook case mbNb of Nothing -> return () - Just nb -> liftIO $notebookSetTabPos nb pos + Just nb -> notebookSetTabPos nb pos -- -- | Split the currently active pane in horizontal direction -- viewSplitHorizontal :: PaneMonad alpha => alpha () -viewSplitHorizontal = viewSplit Horizontal +viewSplitHorizontal = viewSplit OrientationHorizontal -- -- | Split the currently active pane in vertical direction -- viewSplitVertical :: PaneMonad alpha => alpha () -viewSplitVertical = viewSplit Vertical +viewSplitVertical = viewSplit OrientationVertical -- -- | The active view can be split in two (horizontal or vertical) -- -viewSplit :: PaneMonad alpha => Direction -> alpha () -viewSplit dir = do +viewSplit :: PaneMonad alpha => Orientation -> alpha () +viewSplit orientation = do mbPanePath <- getActivePanePath case mbPanePath of Nothing -> return () - Just panePath -> viewSplit' panePath dir + Just panePath -> viewSplit' panePath orientation -viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha () -viewSplit' panePath dir = do +viewSplit' :: PaneMonad alpha => PanePath -> Orientation -> alpha () +viewSplit' panePath orientation = do l <- getLayout case layoutFromPath panePath l of (TerminalP _ _ _ (Just _) _) -> trace "ViewFrame>>viewSplit': can't split detached: " return () _ -> do activeNotebook <- getNotebook' "viewSplit" panePath - ind <- liftIO $ notebookGetCurrentPage activeNotebook - mbPD <- do - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> trace "ViewFrame>>viewSplit': parent not found: " return Nothing - Just parent -> do - (nb,paneDir) <- do - let (name,altname,paneDir, - oldPath,newPath) = case dir of - Horizontal -> ("top", - "bottom", - TopP, - panePath ++ [SplitP TopP], - panePath ++ [SplitP BottomP]) - Vertical -> ("left", - "right", - LeftP, - panePath ++ [SplitP LeftP], - panePath ++ [SplitP RightP]) - adjustNotebooks panePath oldPath - frameState <- getFrameState - setPanePathFromNB $ Map.insert activeNotebook oldPath (panePathFromNB frameState) - nb <- newNotebook newPath - (np,nbi) <- liftIO $ do - newpane <- case dir of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) - rName::Text <- widgetGetName activeNotebook - widgetSetName newpane rName - widgetSetName nb (altname :: Text) - panedPack2 newpane nb True False - nbIndex <- if parent `isA` gTypeNotebook - then notebookPageNum (castToNotebook' "viewSplit'1" parent) activeNotebook - else trace "ViewFrame>>viewSplit': parent not a notebook: " return Nothing - containerRemove (castToContainer parent) activeNotebook - widgetSetName activeNotebook (name :: Text) - panedPack1 newpane activeNotebook True False - return (newpane,nbIndex) - case (reverse panePath, nbi) of - (SplitP dir:_, _) -> liftIO $ - if dir `elem` [TopP, LeftP] - then panedPack1 (castToPaned parent) np True False - else panedPack2 (castToPaned parent) np True False - (GroupP group:_, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook' "viewSplit' 2" parent) np group n - label <- groupLabel group - liftIO $ notebookSetTabLabel (castToNotebook' "viewSplit' 3" parent) np label - label2 <- groupMenuLabel group - liftIO $ notebookSetMenuLabel (castToNotebook' "viewSplit' 4" parent) np label2 - return () - ([], _) -> do - liftIO $ boxPackStart (castToBox parent) np PackGrow 0 - liftIO $ boxReorderChild (castToVBox parent) np 2 - _ -> error "No notebook index found in viewSplit" - liftIO $ do - widgetShowAll np - widgetGrabFocus activeNotebook - case nbi of - Just n -> do - notebookSetCurrentPage (castToNotebook' "viewSplit' 5" parent) n - return () - _ -> trace "ViewFrame>>viewSplit': parent not a notebook2: "return () - return (nb,paneDir) - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ after nb switchPage handleFunc - return (Just (paneDir,dir)) - case mbPD of - Just (paneDir,pdir) -> do - adjustPanes panePath (panePath ++ [SplitP paneDir]) - adjustLayoutForSplit paneDir panePath - mbWidget <- liftIO $ notebookGetNthPage activeNotebook ind - when (isJust mbWidget) $ do - name <- liftIO $ widgetGetName (fromJust mbWidget) + ind <- notebookGetCurrentPage activeNotebook + parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust + let (name,altname,paneDir, + oldPath,newPath) = case orientation of + OrientationHorizontal -> + ( "top" + , "bottom" + , TopP + , panePath ++ [SplitP TopP] + , panePath ++ [SplitP BottomP]) + OrientationVertical -> + ( "left" + , "right" + , LeftP + , panePath ++ [SplitP LeftP] + , panePath ++ [SplitP RightP]) + adjustNotebooks panePath oldPath + frameState <- getFrameState + notebookPtr <- liftIO $ unsafeManagedPtrCastPtr activeNotebook + setPanePathFromNB $ Map.insert notebookPtr oldPath (panePathFromNB frameState) + nb <- newNotebook newPath + newpane <- panedNew $ case orientation of + OrientationHorizontal -> OrientationVertical + OrientationVertical -> OrientationHorizontal + rName <- widgetGetName activeNotebook + widgetSetName newpane rName + widgetSetName nb altname + panedPack2 newpane nb True False + nbIndex <- liftIO (castTo Notebook parent) >>= \case + Just notebook -> notebookPageNum notebook activeNotebook + Nothing -> trace "ViewFrame>>viewSplit': parent not a notebook: " $ return (-1) + containerRemove parent activeNotebook + widgetSetName activeNotebook name + panedPack1 newpane activeNotebook True False + case (reverse panePath, nbIndex) of + (SplitP dir:_, _) -> do + paned <- liftIO $ unsafeCastTo Paned parent + if dir `elem` [TopP, LeftP] + then panedPack1 paned newpane True False + else panedPack2 paned newpane True False + (GroupP group:_, n) | n >= 0 -> do + parentNotebook <- liftIO $ unsafeCastTo Notebook parent + label <- groupLabel group + notebookInsertPage parentNotebook newpane (Just label) n + label2 <- groupMenuLabel group + notebookSetMenuLabel parentNotebook newpane label2 + return () + ([], _) -> do + box <- liftIO $ unsafeCastTo Box parent + boxPackStart box newpane True True 0 + boxReorderChild box newpane 2 + _ -> error "No notebook index found in viewSplit" + widgetShowAll newpane + widgetGrabFocus activeNotebook + if nbIndex >= 0 + then do + parentNotebook <- liftIO $ unsafeCastTo Notebook parent + notebookSetCurrentPage parentNotebook nbIndex + else trace "ViewFrame>>viewSplit': parent not a notebook2: " $ return () + handleFunc <- runInIO (handleNotebookSwitch nb) + afterNotebookSwitchPage nb (\w i -> handleFunc $ fromIntegral i) + adjustPanes panePath (panePath ++ [SplitP paneDir]) + adjustLayoutForSplit paneDir panePath + notebookGetNthPage activeNotebook ind >>= \case + Nothing -> return () + Just widget -> do + name <- widgetGetName widget mbPane <- mbPaneFromName name case mbPane of Just (PaneC pane) -> viewMoveTo (panePath ++ [SplitP (otherDirection paneDir)]) pane Nothing -> return () - Nothing -> return () -- -- | Two notebooks can be collapsed to one @@ -548,10 +562,8 @@ case mbOtherSidePath of Nothing -> trace "ViewFrame>>viewCollapse': no other side path found: " return () Just otherSidePath -> do - nbop <- getNotebookOrPaned otherSidePath castToWidget - let nb = if nbop `isA` gTypeNotebook - then Just (castToNotebook' "viewCollapse' 0" nbop) - else Nothing + nbop <- getNotebookOrPaned otherSidePath return + nb <- liftIO $ castTo Notebook nbop case nb of Nothing -> trace "ViewFrame>>viewCollapse': other side path not collapsedXX: " $ case layoutFromPath otherSidePath layout1 of @@ -561,7 +573,7 @@ HorizontalP{} -> do viewCollapse' (otherSidePath ++ [SplitP TopP]) viewCollapse' panePath - otherwise -> trace "ViewFrame>>viewCollapse': impossible1 " return () + _ -> trace "ViewFrame>>viewCollapse': impossible1 " return () Just otherSideNotebook -> do paneMap <- getPaneMapSt activeNotebook <- getNotebook' "viewCollapse' 1" panePath @@ -576,43 +588,40 @@ mapM_ (\n -> move' (n,activeNotebook)) groupNames -- 2. Remove unused notebook from admin st <- getFrameState - let ! newMap = Map.delete otherSideNotebook (panePathFromNB st) + notebookPtr <- liftIO $ unsafeManagedPtrCastPtr otherSideNotebook + let ! newMap = Map.delete notebookPtr (panePathFromNB st) setPanePathFromNB newMap -- 3. Remove one level and reparent notebook - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> error "collapse: no parent" - Just parent -> do - mbGrandparent <- liftIO $ widgetGetParent parent - case mbGrandparent of - Nothing -> error "collapse: no grandparent" - Just grandparent -> do - nbIndex <- if grandparent `isA` gTypeNotebook - then liftIO $ notebookPageNum (castToNotebook' "viewCollapse'' 1" grandparent) parent - else return Nothing - liftIO $ containerRemove (castToContainer grandparent) parent - liftIO $ containerRemove (castToContainer parent) activeNotebook - if length panePath > 1 - then do - let lasPathElem = last newPanePath - case (lasPathElem, nbIndex) of - (SplitP dir, _) | dir == TopP || dir == LeftP -> - liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True False - (SplitP dir, _) | dir == BottomP || dir == RightP -> - liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True False - (GroupP group, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook' "viewCollapse'' 2" grandparent) activeNotebook group n - label <- groupLabel group - liftIO $ do - notebookSetTabLabel (castToNotebook' "viewCollapse'' 3" grandparent) activeNotebook label - notebookSetCurrentPage (castToNotebook' "viewCollapse'' 4" grandparent) n - return () - _ -> error "collapse: Unable to find page index" - liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem - else liftIO $ do - boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 - boxReorderChild (castToVBox grandparent) activeNotebook 2 - widgetSetName activeNotebook ("root" :: Text) + parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust + grandparent <- widgetGetParent parent >>= liftIO . unsafeCastTo Container . fromJust + nbIndex <- liftIO $ castTo Notebook grandparent >>= \case + Just notebook -> notebookPageNum notebook parent + Nothing -> return (-1) + containerRemove grandparent parent + containerRemove parent activeNotebook + if length panePath > 1 + then do + let lasPathElem = last newPanePath + case (lasPathElem, nbIndex) of + (SplitP dir, _) | dir == TopP || dir == LeftP -> do + paned <- liftIO $ unsafeCastTo Paned grandparent + panedPack1 paned activeNotebook True False + (SplitP dir, _) | dir == BottomP || dir == RightP -> do + paned <- liftIO $ unsafeCastTo Paned grandparent + panedPack2 paned activeNotebook True False + (GroupP group, n) | n >= 0 -> do + grandParentNotebook <- liftIO $ unsafeCastTo Notebook grandparent + label <- groupLabel group + notebookInsertPage grandParentNotebook activeNotebook (Just label) n + notebookSetCurrentPage grandParentNotebook n + return () + _ -> error "collapse: Unable to find page index" + widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem + else do + box <- liftIO $ unsafeCastTo Box grandparent + boxPackStart box activeNotebook True True 0 + boxReorderChild box activeNotebook 2 + widgetSetName activeNotebook "root" -- 4. Change panePathFromNotebook adjustNotebooks panePath newPanePath -- 5. Change paneMap @@ -630,15 +639,19 @@ viewNewGroup :: PaneMonad alpha => alpha () viewNewGroup = do mainWindow <- getMainWindow - mbGroupName <- liftIO $ groupNameDialog mainWindow + mbGroupName <- groupNameDialog mainWindow case mbGroupName of Just groupName -> do layout <- getLayoutSt if groupName `Set.member` allGroupNames layout - then liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose - ("Group name not unique " <> groupName) + then do + md <- new' MessageDialog [ + constructDialogUseHeaderBar 0, + constructMessageDialogButtons ButtonsTypeClose] + setMessageDialogMessageType md MessageTypeWarning + setMessageDialogText md $ "Group name not unique " <> groupName + windowSetTransientFor md (Just mainWindow) dialogRun md widgetDestroy md return () @@ -661,42 +674,35 @@ layout <- getLayoutSt case findGroupPath groupName layout of Just path -> do - widget <- getNotebookOrPaned path castToWidget - liftIO $ setCurrentNotebookPages widget + widget <- getNotebookOrPaned path return + setCurrentNotebookPages widget return (Just path) Nothing -> return Nothing -- Yet another stupid little dialog -groupNameDialog :: Window -> IO (Maybe Text) -groupNameDialog parent = liftIO $ do - dia <- dialogNew - set dia [ windowTransientFor := parent - , windowTitle := ("Enter group name" :: Text) ] - upper <- castToVBox <$> dialogGetContentArea dia - lower <- castToHBox <$> dialogGetActionArea dia - (widget,inj,ext,_) <- buildEditor moduleFields "" - (widget2,_,_,notifier) <- buildEditor okCancelFields () - registerEvent notifier ButtonPressed (\e -> do - case eventText e of - "Ok" -> dialogResponse dia ResponseOk - _ -> dialogResponse dia ResponseCancel - return e) - boxPackStart upper widget PackGrow 7 - boxPackStart lower widget2 PackNatural 7 +groupNameDialog :: (Applicative m, MonadIO m) => Window -> m (Maybe Text) +groupNameDialog parent = do + dia <- new' Dialog [constructDialogUseHeaderBar 0] + setWindowTransientFor dia parent + setWindowTitle dia "Group" + upper <- dialogGetContentArea dia >>= liftIO . unsafeCastTo Box + (widget,inj,ext,_) <- buildEditor fields "" + okButton <- dialogAddButton' dia "New" ResponseTypeOk + boxPackStart upper widget True True 7 widgetShowAll dia resp <- dialogRun dia - value <- ext "" + value <- liftIO $ ext "" widgetDestroy dia - case resp of - ResponseOk | value /= Just "" -> return value - _ -> return Nothing - where - moduleFields :: FieldDescription Text - moduleFields = VFD emptyParams [ + case toEnum $ fromIntegral resp of + ResponseTypeOk | value /= Just "" -> return value + _ -> return Nothing + where + fields :: FieldDescription Text + fields = VFD emptyParams [ mkField - (paraName <<<- ParaName "New group " + (paraName <<<- ParaName "Group name " $ emptyParams) id const @@ -712,23 +718,20 @@ viewNest' :: PaneMonad alpha => PanePath -> Text -> alpha () viewNest' panePath group = do activeNotebook <- getNotebook' "viewNest' 1" panePath - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return () - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP {}) -> do - nb <- newNotebook (panePath ++ [GroupP group]) - liftIO $ widgetSetName nb (groupPrefix <> group) - notebookInsertOrdered activeNotebook nb group Nothing True - liftIO $ widgetShowAll nb - --widgetGrabFocus activeNotebook - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ after nb switchPage handleFunc - adjustLayoutForNest group panePath - _ -> return () + parent <- widgetGetParent activeNotebook + layout <- getLayoutSt + let paneLayout = layoutFromPath panePath layout + case paneLayout of + TerminalP {} -> do + nb <- newNotebook (panePath ++ [GroupP group]) + widgetSetName nb (groupPrefix <> group) + notebookInsertOrdered activeNotebook nb group noLabel Nothing True + widgetShowAll nb + --widgetGrabFocus activeNotebook + handleFunc <- runInIO (handleNotebookSwitch nb) + afterNotebookSwitchPage nb (\w i -> handleFunc $ fromIntegral i) + adjustLayoutForNest group panePath + _ -> return () closeGroup :: PaneMonad alpha => Text -> alpha () closeGroup groupName = do @@ -736,97 +739,95 @@ let mbPath = findGroupPath groupName layout mainWindow <- getMainWindow case mbPath of - Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " <> groupName) return () + Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " <> T.unpack groupName) return () Just path -> do panesMap <- getPaneMapSt let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp) $ map (second fst) (Map.assocs panesMap) continue <- case nameAndpathList of - (_:_) -> liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo - ("Group " <> groupName <> " not empty. Close with all contents?") + (_:_) -> do + md <- new' MessageDialog [ + constructDialogUseHeaderBar 0, + constructMessageDialogButtons ButtonsTypeYesNo] + setMessageDialogMessageType md MessageTypeQuestion + setMessageDialogText md $ "Group " <> groupName <> " not empty. Close with all contents?" + windowSetTransientFor md (Just mainWindow) rid <- dialogRun md widgetDestroy md - case rid of - ResponseYes -> return True - otherwise -> return False + case toEnum $ fromIntegral rid of + ResponseTypeYes -> return True + otherwise -> return False [] -> return True when continue $ do panes <- mapM (paneFromName . fst) nameAndpathList results <- mapM (\ (PaneC p) -> closePane p) panes when (and results) $ do - nbOrPaned <- getNotebookOrPaned path castToWidget - mbParent <- liftIO $ widgetGetParent nbOrPaned - case mbParent of - Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent" - Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned + nbOrPaned <- getNotebookOrPaned path return + parent <- widgetGetParent nbOrPaned >>= liftIO. unsafeCastTo Container . fromJust + containerRemove parent nbOrPaned setLayoutSt (removeGL path layout) ppMap <- getPanePathFromNB setPanePathFromNB (Map.filter (\pa -> not (path `isPrefixOf` pa)) ppMap) -viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget)) +viewDetach :: PaneMonad alpha => alpha (Maybe (Window, Notebook)) viewDetach = do - id <- liftIO $ fmap show getCPUTime + id <- liftIO $ show <$> getCPUTime mbPanePath <- getActivePanePath case mbPanePath of Nothing -> return Nothing Just panePath -> viewDetach' panePath (T.pack id) -viewDetach' :: PaneMonad alpha => PanePath -> Text -> alpha (Maybe (Window,Widget)) +viewDetach' :: PaneMonad alpha => PanePath -> Text -> alpha (Maybe (Window, Notebook)) viewDetach' panePath id = do activeNotebook <- getNotebook' "viewDetach'" panePath - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return Nothing - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP{detachedSize = size}) -> do - window <- liftIO $ do - window <- windowNew - set window [ windowTitle := ("Leksah detached window" :: Text) - , widgetName := Just id ] - case size of - Just (width, height) -> windowSetDefaultSize window width height - Nothing -> do - (Rectangle _ _ curWidth curHeight) <- widgetGetAllocation activeNotebook - windowSetDefaultSize window curWidth curHeight - containerRemove (castToContainer parent) activeNotebook - containerAdd window activeNotebook - widgetShowAll window - return window - handleFunc <- runInIO (handleReattach id window) - liftIO . on window deleteEvent . liftIO $ handleFunc () - windows <- getWindowsSt - setWindowsSt $ windows ++ [window] - adjustLayoutForDetach id panePath - return (Just (window, castToWidget activeNotebook)) - _ -> return Nothing - - + parent <- widgetGetParent activeNotebook >>= liftIO . unsafeCastTo Container . fromJust + layout <- getLayoutSt + let paneLayout = layoutFromPath panePath layout + case paneLayout of + TerminalP{detachedSize = size} -> do + window <- windowNew WindowTypeToplevel + setWindowTitle window "Leksah detached window" + setWidgetName window id + case size of + Just (width, height) -> windowSetDefaultSize window (fromIntegral width) (fromIntegral height) + Nothing -> do + a <- widgetGetAllocation activeNotebook + curWidth <- getRectangleWidth a + curHeight <- getRectangleHeight a + windowSetDefaultSize window curWidth curHeight + containerRemove parent activeNotebook + containerAdd window activeNotebook + widgetShowAll window + handleFunc <- runInIO (handleReattach id window) + onWidgetDeleteEvent window $ \e -> handleFunc () + windows <- getWindowsSt + setWindowsSt $ windows ++ [window] + adjustLayoutForDetach id panePath + return (Just (window, activeNotebook)) + _ -> return Nothing handleReattach :: PaneMonad alpha => Text -> Window -> () -> alpha Bool handleReattach windowId window _ = do layout <- getLayout case findDetachedPath windowId layout of - Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " <> windowId) + Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " <> T.unpack windowId) $ do windows <- getWindowsSt - setWindowsSt $ delete window windows + setWindowsSt $ deleteBy equalManagedPtr window windows return False Just pp -> do nb <- getNotebook' "handleReattach" pp - parent <- getNotebookOrPaned (init pp) castToContainer - liftIO $ containerRemove (castToContainer window) nb - liftIO $ containerAdd parent nb + parent <- getNotebookOrPaned (init pp) (unsafeCastTo Container) + containerRemove window nb + containerAdd parent nb adjustLayoutForReattach pp windows <- getWindowsSt - setWindowsSt $ delete window windows + setWindowsSt $ deleteBy equalManagedPtr window windows case last pp of GroupP groupName -> do label <- groupLabel groupName - liftIO $ notebookSetTabLabel (castToNotebook' "handleReattach" parent) nb label + parentNotebook <- liftIO $ unsafeCastTo Notebook parent + notebookSetTabLabel parentNotebook nb (Just label) otherwise -> return () return False -- "now destroy the window" @@ -838,38 +839,34 @@ Nothing -> return Nothing Just panePath -> do activeNotebook <- getNotebook' "getActiveWindow" panePath - top <- liftIO $ widgetGetToplevel activeNotebook - if top `isA` gTypeWindow - then return . Just $ castToWindow top - else return Nothing + widgetGetToplevel activeNotebook >>= liftIO . castTo Window getActiveScreen :: PaneMonad alpha => alpha (Maybe Screen) getActiveScreen = do mbWindow <- getActiveWindow case mbWindow of Nothing -> return Nothing - Just window -> liftIO $ Just <$> windowGetScreen window + Just window -> Just <$> windowGetScreen window groupMenuLabel :: PaneMonad beta => Text -> beta (Maybe Label) -groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) +groupMenuLabel group = liftM Just (labelNew (Just group)) handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta () -handleNotebookSwitch nb index = do - mbW <- liftIO $ notebookGetNthPage nb index - case mbW of +handleNotebookSwitch nb index = + notebookGetNthPage nb (fromIntegral index) >>= \case Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget" Just w -> do - name <- liftIO $ widgetGetName w - mbPane <- findPaneFor name + name <- widgetGetName w + mbPane <- findPaneFor name case mbPane of Nothing -> return () Just (PaneC p) -> makeActive p - where + where findPaneFor :: PaneMonad beta => Text -> beta (Maybe (IDEPane beta)) findPaneFor n1 = do panes' <- getPanesSt foldM (\r (PaneC p) -> do - n2 <- liftIO $ widgetGetName (getTopWidget p) + n2 <- widgetGetName =<< getTopWidget p return (if n1 == n2 then Just (PaneC p) else r)) Nothing (Map.elems panes') @@ -934,22 +931,23 @@ case groupPrefix `T.stripPrefix` paneName of Just group -> case findGroupPath group layout of - Nothing -> trace ("ViewFrame>>move': group not found: " <> group) return () + Nothing -> trace ("ViewFrame>>move': group not found: " <> T.unpack group) return () Just fromPath -> do - groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget + groupNBOrPaned <- getNotebookOrPaned fromPath return fromNB <- getNotebook' "move'" (init fromPath) - case toNB `Map.lookup` panePathFromNB frameState of + toNBPtr <- liftIO $ unsafeManagedPtrCastPtr toNB + case toNBPtr `Map.lookup` panePathFromNB frameState of Nothing -> trace "ViewFrame>>move': panepath for Notebook not found1" return () Just toPath -> - when (fromNB /= toNB && not (fromPath `isPrefixOf` toPath)) $ do - mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned - case mbNum of - Nothing -> trace "ViewFrame>>move': group notebook not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num + when (not (fromNB `equalManagedPtr` toNB || fromPath `isPrefixOf` toPath)) $ do + num <- notebookPageNum fromNB groupNBOrPaned + if num < 0 + then trace "ViewFrame>>move': group notebook not found" return () + else do + notebookRemovePage fromNB num label <- groupLabel group - notebookInsertOrdered toNB groupNBOrPaned group Nothing True - liftIO $ notebookSetTabLabel toNB groupNBOrPaned label + notebookInsertOrdered toNB groupNBOrPaned group noLabel Nothing True + notebookSetTabLabel toNB groupNBOrPaned (Just label) adjustPanes fromPath (toPath ++ [GroupP group]) adjustLayoutForGroupMove fromPath toPath group adjustNotebooks fromPath (toPath ++ [GroupP group]) @@ -957,25 +955,26 @@ return () Nothing -> case paneName `Map.lookup` panes of - Nothing -> trace ("ViewFrame>>move': pane not found: " <> paneName) return () - Just (PaneC pane) -> - case toNB `Map.lookup` panePathFromNB frameState of + Nothing -> trace ("ViewFrame>>move': pane not found: " <> T.unpack paneName) return () + Just (PaneC pane) -> do + toNBPtr <- liftIO $ unsafeManagedPtrCastPtr toNB + case toNBPtr `Map.lookup` panePathFromNB frameState of Nothing -> trace "ViewFrame>>move': panepath for Notebook not found2" return () Just toPath -> case paneName `Map.lookup`paneMap of - Nothing -> trace ("ViewFrame>>move': pane data not found: " <> paneName) + Nothing -> trace ("ViewFrame>>move': pane data not found: " <> T.unpack paneName) return () Just (fromPath,_) -> do - let child = getTopWidget pane + child <- getTopWidget pane (fromPane,cid) <- guiPropertiesFromName paneName fromNB <- getNotebook' "move'" fromPane - when (fromNB /= toNB) $ do - mbNum <- liftIO $ notebookPageNum fromNB child - case mbNum of - Nothing -> trace "ViewFrame>>move': widget not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num - notebookInsertOrdered toNB child paneName Nothing False + unless (fromNB `equalManagedPtr` toNB) $ do + num <- notebookPageNum fromNB child + if num < 0 + then trace "ViewFrame>>move': widget not found" return () + else do + notebookRemovePage fromNB num + notebookInsertOrdered toNB child paneName noLabel (paneTooltipText pane) False let paneMap1 = Map.delete paneName paneMap setPaneMapSt $ Map.insert paneName (toPath,cid) paneMap1 @@ -993,31 +992,27 @@ -- -- | Bring the pane to the front position in its notebook -- -bringPaneToFront :: RecoverablePane alpha beta delta => alpha -> IO () +bringPaneToFront :: RecoverablePane alpha beta delta => alpha -> delta () bringPaneToFront pane = do - let tv = getTopWidget pane + tv <- getTopWidget pane w <- widgetGetToplevel tv - visible <- w `get` widgetVisible - when visible . windowPresent $ castToWindow w + visible <- getWidgetVisible w + when visible $ liftIO (unsafeCastTo Window w) >>= windowPresent setCurrentNotebookPages tv +setCurrentNotebookPages :: (MonadIO m, IsWidget widget) => widget -> m () setCurrentNotebookPages widget = do mbParent <- widgetGetParent widget case mbParent of Just parent -> do setCurrentNotebookPages parent - when (parent `isA` gTypeNotebook) $ do - mbPageNum <- notebookPageNum - (castToNotebook' "setCurrentNotebookPage 1" parent) - widget - case mbPageNum of - Just pageNum -> do - notebookSetCurrentPage - (castToNotebook' "setCurrentNotebookPage 2" parent) - pageNum - return () - Nothing -> return () + liftIO (castTo Notebook parent) >>= \case + Just notebook -> + notebookPageNum notebook widget >>= \case + -1 -> return () + pageNum -> notebookSetCurrentPage notebook pageNum + Nothing -> return () Nothing -> return () -- @@ -1053,10 +1048,10 @@ newNotebook' = do nb <- notebookNew widgetSetSizeRequest nb 50 50 - notebookSetTabPos nb PosTop + notebookSetTabPos nb PositionTypeTop notebookSetShowTabs nb True notebookSetScrollable nb True - notebookSetPopup nb True + setNotebookEnablePopup nb True return nb -- @@ -1066,31 +1061,32 @@ newNotebook pp = do st <- getFrameState nb <- liftIO newNotebook' - setPanePathFromNB $ Map.insert nb pp (panePathFromNB st) + nbPtr <- liftIO $ unsafeManagedPtrCastPtr nb + setPanePathFromNB $ Map.insert nbPtr pp (panePathFromNB st) func <- runInIO move' - liftIO $ do - tl <- targetListNew - targetListAddTextTargets tl 0 - dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove] - dragDestSetTargetList nb tl - on nb dragDataReceived (dragFunc nb func) - return nb - where + tl <- targetListNew Nothing + targetListAddTextTargets tl 0 + widgetDragDestSet nb [DestDefaultsAll] Nothing [DragActionCopy, DragActionMove] + widgetDragDestSetTargetList nb $ Just tl + onWidgetDragDataReceived nb (dragFunc nb func) + return nb + where dragFunc :: Notebook -> ((PaneName,Notebook) -> IO ()) -> DragContext -> - Point -> - InfoId -> - TimeStamp -> - SelectionDataM () - dragFunc nb func cont point id timeStamp = do - mbText <- selectionDataGetText - case mbText of - Nothing -> return () + Int32 -> + Int32 -> + SelectionData -> + Word32 -> + Word32 -> + IO () + dragFunc nb func cont x y data_ id timeStamp = + selectionDataGetText data_ >>= \case + Nothing -> return () Just str -> do - Gtk.liftIO $ func (str,nb) - return () + trace ("dragFunc str=" <> T.unpack str) $ return () + func (str,nb) terminalsWithPanePath :: PaneLayout -> [(PanePath,PaneLayout)] terminalsWithPanePath pl = map (first reverse) $ terminalsWithPP [] pl @@ -1186,7 +1182,7 @@ nameList (pe:rpath) (_:rlayout) = panePathElementToWidgetName pe : nameList rpath rlayout nameList _ _ = error $ "inconsistent layout (getWidgetNameList) " ++ show path ++ " " ++ show layout -getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta +getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> IO beta) -> alpha beta getNotebookOrPaned p cf = do layout <- getLayout (widgetGet $ getWidgetNameList p layout) cf @@ -1195,17 +1191,17 @@ -- | Get the notebook widget for the given pane path -- getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook -getNotebook p = getNotebookOrPaned p (castToNotebook' ("getNotebook " <> T.pack (show p))) +getNotebook p = getNotebookOrPaned p (unsafeCastTo Notebook) getNotebook' :: PaneMonad alpha => Text -> PanePath -> alpha Notebook -getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " <> str <> " " <> T.pack (show p))) +getNotebook' str p = getNotebookOrPaned p (unsafeCastTo Notebook) -- -- | Get the (gtk) Paned widget for a given path -- getPaned :: PaneMonad alpha => PanePath -> alpha Paned -getPaned p = getNotebookOrPaned p castToPaned +getPaned p = getNotebookOrPaned p $ unsafeCastTo Paned -- -- | Get the path to the active pane @@ -1267,7 +1263,7 @@ adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha () adjustNotebooks fromPane toPane = do - npMap <- trace ("+++ adjustNotebooks from: " <> T.pack (show fromPane) <> " to " <> T.pack (show toPane)) + npMap <- trace ("+++ adjustNotebooks from: " <> show fromPane <> " to " <> show toPane) getPanePathFromNB setPanePathFromNB (Map.map (\pp -> case stripPrefix fromPane pp of @@ -1400,13 +1396,13 @@ -- -- | Get the widget from a list of strings -- -widgetFromPath :: Widget -> [Text] -> IO Widget +widgetFromPath :: MonadIO m => Widget -> [Text] -> m Widget widgetFromPath w [] = return w widgetFromPath w path = do - children <- containerGetChildren (castToContainer w) + children <- liftIO (unsafeCastTo Container w) >>= containerGetChildren chooseWidgetFromPath children path -chooseWidgetFromPath :: [Widget] -> [Text] -> IO Widget +chooseWidgetFromPath :: MonadIO m => [Widget] -> [Text] -> m Widget chooseWidgetFromPath _ [] = error "Cant't find widget (empty path)" chooseWidgetFromPath widgets (h:t) = do names <- mapM widgetGetName widgets @@ -1415,25 +1411,25 @@ Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names Just ind -> widgetFromPath (widgets !! ind) t -widgetGet :: PaneMonad alpha => [Text] -> (Widget -> b) -> alpha b +widgetGet :: PaneMonad alpha => [Text] -> (Widget -> IO b) -> alpha b widgetGet strL cf = do windows <- getWindowsSt - r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL - return (cf r) + widgets <- liftIO $ mapM toWidget windows + r <- liftIO $ chooseWidgetFromPath widgets strL + liftIO (cf r) widgetGetRel :: Widget -> [Text] -> (Widget -> b) -> IO b widgetGetRel w sl cf = do r <- widgetFromPath w sl return (cf r) -getUIAction :: PaneMonad alpha => Text -> (Action -> a) -> alpha a +getUIAction :: PaneMonad alpha => Text -> (Action -> IO a) -> alpha a getUIAction str f = do uiManager <- getUiManagerSt - liftIO $ do - findAction <- uiManagerGetAction uiManager str - case findAction of - Just act -> return (f act) - Nothing -> error $"getUIAction can't find action " ++ T.unpack str + findAction <- uIManagerGetAction uiManager str + case findAction of + Just act -> liftIO $ f act + Nothing -> error $"getUIAction can't find action " ++ T.unpack str getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha getThis sel = do @@ -1442,12 +1438,12 @@ setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta () setThis sel value = do st <- getFrameState - trace ("!!! setFrameState " <> T.pack (show $ sel st value)) $ setFrameState (sel st value) + trace ("!!! setFrameState " <> show (sel st value)) $ setFrameState (sel st value) getWindowsSt = getThis windows setWindowsSt = setThis (\st value -> st{windows = value}) getUiManagerSt = getThis uiManager -getPanesSt = getThis panes +getPanesSt = getThis panes setPanesSt = setThis (\st value -> st{panes = value}) getPaneMapSt = getThis paneMap setPaneMapSt = setThis (\st value -> st{paneMap = value}) @@ -1464,9 +1460,4 @@ getWindows = getWindowsSt getMainWindow = liftM head getWindows getLayout = getLayoutSt - -castToNotebook' :: GObjectClass obj => Text -> obj -> Notebook -castToNotebook' str obj = if obj `isA` gTypeNotebook - then castToNotebook obj - else error . T.unpack $ "Not a notebook " <> str diff --git a/src/Graphics/UI/Utils.hs b/src/Graphics/UI/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Utils.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} +module Graphics.UI.Utils ( + setPrimaryAlign + , setSecondaryAlign + , setPrimaryExpand + , setSecondaryExpand +) where + +import Control.Monad.IO.Class (MonadIO) +import GI.Gtk + (widgetSetVexpand, widgetSetHexpand, widgetSetValign, + widgetSetHalign, orientableGetOrientation, Align, IsWidget, + IsOrientable) +import GI.Gtk.Enums (Orientation(..)) + +setPrimaryAlign :: (MonadIO m, IsOrientable parent, IsWidget child) => parent -> child -> Align -> m () +setPrimaryAlign parent child align = + orientableGetOrientation parent >>= \case + OrientationHorizontal -> widgetSetHalign child align + OrientationVertical -> widgetSetValign child align + +setPrimaryExpand :: (MonadIO m, IsOrientable parent, IsWidget child) => parent -> child -> Bool -> m () +setPrimaryExpand parent child expand = + orientableGetOrientation parent >>= \case + OrientationHorizontal -> widgetSetHexpand child expand + OrientationVertical -> widgetSetVexpand child expand + +setSecondaryAlign :: (MonadIO m, IsOrientable parent, IsWidget child) => parent -> child -> Align -> m () +setSecondaryAlign parent child align = + orientableGetOrientation parent >>= \case + OrientationHorizontal -> widgetSetValign child align + OrientationVertical -> widgetSetHalign child align + +setSecondaryExpand :: (MonadIO m, IsOrientable parent, IsWidget child) => parent -> child -> Bool -> m () +setSecondaryExpand parent child expand = + orientableGetOrientation parent >>= \case + OrientationHorizontal -> widgetSetVexpand child expand + OrientationVertical -> widgetSetHexpand child expand + diff --git a/src/Text/PrinterParser.hs b/src/Text/PrinterParser.hs --- a/src/Text/PrinterParser.hs +++ b/src/Text/PrinterParser.hs @@ -35,6 +35,11 @@ , showFields , readFields , parseFields +, Color(..) +, toGdkColor +, fromGdkColor +, toGdkRGBA +, fromGdkRGBA ) where import Text.ParserCombinators.Parsec.Language @@ -46,7 +51,6 @@ import Graphics.UI.Editor.Basics import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid ((<>)) -import Graphics.UI.Gtk (Color(..)) import Data.List (foldl') import qualified Text.ParserCombinators.Parsec as P ((), CharParser(..), parseFromFile) @@ -54,7 +58,18 @@ import qualified Data.Text as T (pack, unpack) import Data.Text (Text) import Control.Applicative ((<$>)) - +import Numeric (showHex) +import System.IO.Unsafe (unsafePerformIO) +import Data.Word (Word16) +import Control.Monad.IO.Class (MonadIO) +import qualified GI.Gdk.Structs.Color as Gdk (Color(..)) +import Data.GI.Base.Constructible (Constructible(..)) +import GI.Gdk.Structs.Color + (getColorBlue, getColorGreen, getColorRed, setColorBlue, + setColorGreen, setColorRed) +import GI.Gdk + (setRGBAAlpha, getRGBABlue, getRGBAGreen, getRGBARed, setRGBABlue, + setRGBAGreen, setRGBARed, newZeroRGBA, RGBA) type Printer beta = beta -> PP.Doc type Parser beta = CharParser () beta @@ -156,6 +171,8 @@ i <- integer return (fromIntegral i) +data Color = Color Word16 Word16 Word16 deriving(Eq, Show) + colorParser :: CharParser () Color colorParser = do string "Color" @@ -166,6 +183,37 @@ whiteSpace b <- integer return $ Color (fromIntegral r) (fromIntegral g) (fromIntegral b) + +toGdkColor :: MonadIO m => Color -> m Gdk.Color +toGdkColor (Color r g b) = do + c <- new Gdk.Color [] + setColorRed c r + setColorGreen c g + setColorBlue c b + return c + +fromGdkColor :: MonadIO m => Gdk.Color -> m Color +fromGdkColor c = do + r <- getColorRed c + g <- getColorGreen c + b <- getColorBlue c + return $ Color r g b + +toGdkRGBA :: MonadIO m => Color -> m RGBA +toGdkRGBA (Color r g b) = do + c <- newZeroRGBA + setRGBARed c (fromIntegral r / 65535) + setRGBAGreen c (fromIntegral g / 65535) + setRGBABlue c (fromIntegral b / 65535) + setRGBAAlpha c 65535 + return c + +fromGdkRGBA :: MonadIO m => RGBA -> m Color +fromGdkRGBA c = do + r <- getRGBARed c + g <- getRGBAGreen c + b <- getRGBABlue c + return $ Color (round (r * 65535)) (round (g * 65535)) (round (b * 65535)) emptyParser :: CharParser () () emptyParser = pzero