Merge pull request #7 from leksah/master

Use haskell-gi and add support for GHC 8

Author: hamishmack

.travis.yml

@@ -1,30 +1,36 @@
-env:
-  - GHCVER=7.4.1
-  - GHCVER=7.4.2
-  - GHCVER=7.6.3
-  - GHCVER=7.8.3
+language: haskell
+
+sudo: false
+
+matrix:
+  include:
+    - env: CABALVER=1.22 GHCVER=7.8.3
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.3,happy-1.19.5,alex-3.1.4,libwebkitgtk-dev,libwebkitgtk-3.0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.8.4
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.4,libwebkitgtk-dev,libwebkitgtk-3.0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.1
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4,libwebkitgtk-dev,libwebkitgtk-3.0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.2
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4,libwebkitgtk-dev,libwebkitgtk-3.0-dev], sources: [hvr-ghc]}}
+    - env: CABALVER=head GHCVER=head
+      addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.4,libwebkitgtk-dev,libwebkitgtk-3.0-dev],  sources: [hvr-ghc]}}
+  allow_failures:
+    - env: CABALVER=1.22 GHCVER=7.10.2
+    - env: CABALVER=head GHCVER=head
 
 before_install:
-  - sudo add-apt-repository -y ppa:hvr/ghc
-  - sudo apt-get update -qq
-  - sudo apt-get --no-install-recommends install libgtk2.0-dev libgtk-3-dev
-  - sudo apt-get install cabal-install-1.20 ghc-$GHCVER
-  - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
-  - cabal update
-  - |
-    if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ]; then
-      sudo apt-get install happy-1.19.3 alex-3.1.3
-      export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH
-    else
-      sudo apt-get install happy alex
-    fi
+  - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.5/bin:$PATH
 
 install:
-  - cabal install Cabal
+  - cabal --version
+  - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+  - cabal update
   - cabal install gtk2hs-buildtools
 
 script:
-  - cabal install
+  - cd vcsgui
+  - cabal install -v2
+  - cabal check
 
 notifications:
   irc:

vcsgui/src/Main.hs

@@ -24,8 +24,8 @@ import qualified VCSGui.Git.Log as GitLog
 import qualified VCSGui.Git.Commit as GitCommit
 import qualified VCSGui.Mercurial.Commit as MercurialCommit
 import qualified VCSGui.Mercurial.Log as MercurialLog
-import Graphics.UI.Gtk
 import Control.Monad.Trans(liftIO)
+import qualified GI.Gtk.Functions as Gtk (main, init)
 --
 --svn
 --
@@ -165,10 +165,10 @@ main = do
 
 --{-
 main = do
-        initGUI
+        Gtk.init Nothing
         runWithConfig $
             MercurialLog.showLogGUI
-        mainGUI
+        Gtk.main
     where
         runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwdMercurial) Nothing Nothing
 ---}

vcsgui/src/VCSGui/Common/Commit.hs

@@ -25,14 +25,22 @@ module VCSGui.Common.Commit (
 
 import qualified VCSWrapper.Common as Wrapper
 import qualified VCSGui.Common.GtkHelper as H
-import Graphics.UI.Gtk
 import Control.Monad.Trans(liftIO)
 import Control.Monad
 import Control.Monad.Reader
 import Data.Maybe
 import Paths_vcsgui(getDataFileName)
 import qualified Data.Text as T (unpack, pack)
 import Data.Text (Text)
+import GI.Gtk.Objects.TreeView (TreeView(..))
+import Data.GI.Gtk.ModelView.SeqStore
+       (seqStoreAppend, seqStoreClear, seqStoreToList, SeqStore(..))
+import GI.Gtk.Objects.Action (onActionActivate)
+import GI.Gtk.Objects.Widget (widgetShowAll)
+import GI.Gtk.Objects.Builder (builderGetObject, Builder(..))
+import Foreign.ForeignPtr (ForeignPtr)
+import Data.GI.Base.BasicTypes (NullToNothing(..), GObject)
+import Data.GI.Base.ManagedPtr (unsafeCastTo)
 
 --
 -- glade path and object accessors
@@ -55,9 +63,9 @@ type OkCallBack = Text    -- ^ Commit message as specified in the GUI.
             -> [Option]     -- ^ options (this is currently not implemented i.e. '[]' is passed)
             -> Wrapper.Ctx ()
 
--- | fn to set listStore model for treeview
+-- | fn to set seqStore model for treeview
 type TreeViewSetter = TreeView
-                   -> Wrapper.Ctx (ListStore SCFile)
+                   -> Wrapper.Ctx (SeqStore SCFile)
 
 
 data CommitGUI = CommitGUI {
@@ -110,7 +118,7 @@ showCommitGUI setUpTreeView okCallback = do
     liftIO $ H.registerClose $ windowCommit gui
     liftIO $ H.registerCloseAction (actCancel gui) (windowCommit gui)
     config <- ask
-    liftIO $ on (H.getItem (actCommit gui)) actionActivated $ do
+    liftIO $ onActionActivate (H.getItem (actCommit gui)) $ do
                                         let (store,_) = H.getItem (treeViewFiles gui)
                                         selectedFiles <- getSelectedFiles store
                                         mbMsg <- H.get (txtViewMsg gui)
@@ -129,7 +137,7 @@ showCommitGUI setUpTreeView okCallback = do
 
 
 
-loadCommitGUI :: TreeViewSetter   -- ^ fn to set listStore model for treeview
+loadCommitGUI :: TreeViewSetter   -- ^ fn to set seqStore model for treeview
                 -> Wrapper.Ctx CommitGUI
 loadCommitGUI setUpTreeView = do
                 gladepath <- liftIO getGladepath
@@ -145,9 +153,9 @@ loadCommitGUI setUpTreeView = do
 ---- HELPERS
 ----
 
-getSelectedFiles :: ListStore SCFile -> IO [FilePath]
-getSelectedFiles listStore = do
-            listedFiles <- listStoreToList listStore
+getSelectedFiles :: SeqStore SCFile -> IO [FilePath]
+getSelectedFiles seqStore = do
+            listedFiles <- seqStoreToList seqStore
             let selectedFiles = map (\scf -> filePath scf )
                                 $ filter (\scf -> selected scf) listedFiles
             return (selectedFiles)
@@ -156,39 +164,39 @@ getTreeViewFromGladeCustomStore :: Builder
                         -> Text
                         -> TreeViewSetter
                         -> Wrapper.Ctx (H.TreeViewItem SCFile)
-getTreeViewFromGladeCustomStore builder name setupListStore = do
-    (_, tView) <- liftIO $ wrapWidget builder castToTreeView name
-    store <- setupListStore tView
-    let getter = getFromListStore (store, tView)
-        setter = setToListStore (store, tView)
+getTreeViewFromGladeCustomStore builder name setupSeqStore = do
+    (_, tView) <- liftIO $ wrapWidget builder TreeView name
+    store <- setupSeqStore tView
+    let getter = getFromSeqStore (store, tView)
+        setter = setToSeqStore (store, tView)
     return (name, (store, tView), (getter, setter))
 
 ---
 --- same as gtkhelper, but avoiding exposing it
 ---
-wrapWidget :: GObjectClass objClass =>
+wrapWidget :: GObject objClass =>
      Builder
-     -> (GObject -> objClass)
+     -> (ForeignPtr objClass -> objClass)
      -> Text -> IO (Text, objClass)
-wrapWidget builder cast name = do
+wrapWidget builder constructor name = do
     putStrLn $ " cast " ++ T.unpack name
-    gobj <- builderGetObject builder cast name
+    gobj <- nullToNothing (builderGetObject builder name) >>= unsafeCastTo constructor . fromJust
     return (name, gobj)
 
-getFromListStore :: (ListStore a, TreeView)
+getFromSeqStore :: (SeqStore a, TreeView)
     -> IO (Maybe [a])
-getFromListStore (store, _) = do
-    list <- listStoreToList store
+getFromSeqStore (store, _) = do
+    list <- seqStoreToList store
     if null list
         then return Nothing
         else return $ Just list
 
-setToListStore :: (ListStore a, TreeView)
+setToSeqStore :: (SeqStore a, TreeView)
     -> [a]
     -> IO ()
-setToListStore (store, view) newList = do
-    listStoreClear store
-    mapM_ (listStoreAppend store) newList
+setToSeqStore (store, view) newList = do
+    seqStoreClear store
+    mapM_ (seqStoreAppend store) newList
     return ()
 
 

vcsgui/src/VCSGui/Common/ConflictsResolved.hs

@@ -21,8 +21,9 @@ import qualified VCSWrapper.Common as Wrapper
 import Paths_vcsgui(getDataFileName)
 import qualified VCSGui.Common.GtkHelper as H
 import Control.Monad.Trans(liftIO)
-import Graphics.UI.Gtk
 import Control.Monad.Reader(ask)
+import GI.Gtk.Objects.Action (onActionActivate)
+import GI.Gtk.Objects.Widget (widgetShowAll)
 
 --
 -- glade path and object accessors
@@ -50,11 +51,11 @@ showConflictsResolvedGUI handler = do
     -- connect actions
     liftIO $ H.registerClose $ windowConflictsResolved gui
     config <- ask
-    liftIO $ on (H.getItem (actConflictsNotResolved gui)) actionActivated $ do
+    liftIO $ onActionActivate (H.getItem (actConflictsNotResolved gui)) $ do
                                         Wrapper.runVcs config $ handler False
                                         H.closeWin (windowConflictsResolved gui)
 
-    liftIO $ on (H.getItem (actConflictsResolved gui)) actionActivated $ do
+    liftIO $ onActionActivate (H.getItem (actConflictsResolved gui)) $ do
                                         Wrapper.runVcs config $ handler True
                                         H.closeWin (windowConflictsResolved gui)
 

vcsgui/src/VCSGui/Common/Error.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 -----------------------------------------------------------------------------
 --
@@ -17,14 +18,24 @@ module VCSGui.Common.Error (
     showErrorGUI
 ) where
 
-import Graphics.UI.Gtk
 import Data.Text (Text)
+import GI.Gtk.Objects.Dialog (dialogUseHeaderBar, dialogRun)
+import GI.Gtk.Objects.Widget (widgetDestroy)
+import Data.GI.Base (new)
+import GI.Gtk.Objects.MessageDialog
+       (messageDialogMessageType, messageDialogButtons,
+        setMessageDialogText, MessageDialog(..))
+import GI.Gtk.Enums (ButtonsType(..), MessageType(..))
+import Data.GI.Base.Attributes (AttrOp(..))
 
 -- | Displays a simple window displaying given 'String' as an error message.
 showErrorGUI :: Text -- ^ Message to display.
     -> IO ()
 showErrorGUI msg = do
-    dialog <- messageDialogNew Nothing [] MessageError ButtonsOk msg
+    dialog <- new MessageDialog [dialogUseHeaderBar := 0,
+                                 messageDialogMessageType := MessageTypeError,
+                                 messageDialogButtons := ButtonsTypeOk]
+    setMessageDialogText dialog msg
     _ <- dialogRun dialog
     widgetDestroy dialog
     return ()