ltk 0.15.0.5 → 0.16.1.0
raw patch · 12 files changed
+1423/−1051 lines, 12 filesdep +base-compatdep +gi-cairodep +gi-gdkdep −glibdep −gtk3dep ~Cabaldep ~basedep ~transformers
Dependencies added: base-compat, gi-cairo, gi-gdk, gi-glib, gi-gobject, gi-gtk, gi-gtk-hs, haskell-gi-base, haskell-gi-overloading
Dependencies removed: glib, gtk3
Dependency ranges changed: Cabal, base, transformers
Files
- ltk.cabal +76/−21
- src/Graphics/UI/Editor/Basics.hs +37/−25
- src/Graphics/UI/Editor/Composite.hs +263/−221
- src/Graphics/UI/Editor/DescriptionPP.hs +1/−1
- src/Graphics/UI/Editor/MakeEditor.hs +130/−72
- src/Graphics/UI/Editor/Parameters.hs +73/−61
- src/Graphics/UI/Editor/Simple.hs +206/−169
- src/Graphics/UI/Frame/Panes.hs +21/−10
- src/Graphics/UI/Frame/Rectangle.hs +67/−0
- src/Graphics/UI/Frame/ViewFrame.hs +460/−469
- src/Graphics/UI/Utils.hs +39/−0
- src/Text/PrinterParser.hs +50/−2
ltk.cabal view
@@ -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+
src/Graphics/UI/Editor/Basics.hs view
@@ -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]
src/Graphics/UI/Editor/Composite.hs view
@@ -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
src/Graphics/UI/Editor/DescriptionPP.hs view
@@ -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
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -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)
src/Graphics/UI/Editor/Parameters.hs view
@@ -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
src/Graphics/UI/Editor/Simple.hs view
@@ -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)]-
src/Graphics/UI/Frame/Panes.hs view
@@ -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)
+ src/Graphics/UI/Frame/Rectangle.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Core.ViewFrame+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -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 ("<b>" <> group <> "</b>")+ label <- labelNew Nothing+ labelSetUseMarkup label True+ labelSetMarkup label ("<b>" <> group <> "</b>") 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 "<span foreground=\"red\">" <> text <> "</span>"- 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 "<span foreground=\"red\">" <> text <> "</span>"+ 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
+ src/Graphics/UI/Utils.hs view
@@ -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+
src/Text/PrinterParser.hs view
@@ -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