diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ivan Perez (Keera Studios) 2010-2012 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Perez nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/gtk3-helpers.cabal b/gtk3-helpers.cabal new file mode 100644 --- /dev/null +++ b/gtk3-helpers.cabal @@ -0,0 +1,89 @@ +Name: gtk3-helpers +Version: 0.1.0 +Synopsis: A collection of auxiliary operations and widgets related to Gtk +Description: A collection of auxiliary operations and widgets related to Gtk+. +Homepage: http://keera.co.uk/blog/community +License: BSD3 +License-file: LICENSE +Author: Ivan Perez +Maintainer: ivan.perez@keera.co.uk +-- Copyright: +Stability: Experimental +Category: Graphics +Build-type: Simple +-- Extra-source-files: +cabal-version: >= 1.10 + +Library + default-language: Haskell2010 + + -- Exposed-modules: + Build-depends: base >=4 && < 5, template-haskell, process, gtk3, gio, glib, mtl, array + -- Other-modules: + hs-source-dirs: src/ + -- Build-tools: + ghc-options: -Wall + + exposed-modules: + -- Data.Board.GameBoardIO + -- , Game.Board.BasicTurnGame + -- , Graphics.UI.Gtk.Board.TiledBoard + -- , Graphics.UI.Gtk.Board.BoardLink + -- , Graphics.UI.Gtk.Entry.FormatEntry + -- , Graphics.UI.Gtk.Entry.HighlightedEntry + Graphics.UI.Gtk.Extra.Builder + , Graphics.UI.Gtk.Extra.BuilderTH + , Graphics.UI.Gtk.Helpers.Combo + -- , Graphics.UI.Gtk.Helpers.FileDialog + -- , Graphics.UI.Gtk.Helpers.MenuItem + -- , Graphics.UI.Gtk.Helpers.MessageDialog + -- , Graphics.UI.Gtk.Helpers.ModelViewNotebookSync + -- , Graphics.UI.Gtk.Helpers.ModelViewPath + -- , Graphics.UI.Gtk.Helpers.Multiline.TextBuffer + -- , Graphics.UI.Gtk.Helpers.Pixbuf + -- , Graphics.UI.Gtk.Helpers.TreeView + -- , Graphics.UI.Gtk.Layout.BackgroundContainer + -- , Graphics.UI.Gtk.Layout.DummyBin + -- , Graphics.UI.Gtk.Layout.EitherWidget + -- , Graphics.UI.Gtk.Layout.MaybeWidget + , System.Application + +-- You can disable the hlint test suite with -f-test-hlint +flag test-hlint + default: False + manual: True + +-- You can disable the haddock coverage test suite with -f-test-doc-coverage +flag test-doc-coverage + default: False + manual: True + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + default-language: Haskell2010 + hs-source-dirs: tests + if !flag(test-hlint) + buildable: False + else + build-depends: + base, + hlint >= 1.7 + +-- Verify that the code is thoroughly documented +test-suite haddock-coverage + type: exitcode-stdio-1.0 + main-is: HaddockCoverage.hs + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: tests + + if !flag(test-doc-coverage) + buildable: False + else + build-depends: + base >= 4 && < 5, + directory, + filepath, + process, + regex-posix diff --git a/src/Graphics/UI/Gtk/Extra/Builder.hs b/src/Graphics/UI/Gtk/Extra/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Gtk/Extra/Builder.hs @@ -0,0 +1,39 @@ +-- | A collection of small functions to help retrieve +-- information from Glade files. + +module Graphics.UI.Gtk.Extra.Builder + ( fromBuilder + , loadInterface + ) + where + +import Graphics.UI.Gtk + +-- | Graphics.UI.Gtk.builderGetObject with the arguments flipped +-- (Builder goes last). +fromBuilder :: (GObjectClass cls) => + (GObject -> cls) -> String -> Builder -> IO cls +fromBuilder f s b = builderGetObject b f s + +-- | Returns a builder from which the objects in this part of the interface +-- can be accessed. +loadInterface :: String -> IO Builder +loadInterface fn = builderNew `incidentallyM` (`builderAddFromFile` fn) +-- It can be written in point-free style, but I'm not sure it's +-- clearer +-- loadInterface = incidentallyM builderNew . flip builderAddFromFile + +-- -- | Returns a builder from which the objects in this part of the interface +-- -- +-- -- can be accessed. +-- loadInterface :: String -> IO Builder +-- loadInterface builderPath = do +-- builder <- builderNew +-- builderAddFromFile builder builderPath +-- return builder + +-- | Sequences two monadic computations and returns the +-- result of the first. +incidentallyM :: Monad m => m a -> (a -> m b) -> m a +incidentallyM op f = op >>= (\x -> (f x >> return x)) + diff --git a/src/Graphics/UI/Gtk/Extra/BuilderTH.hs b/src/Graphics/UI/Gtk/Extra/BuilderTH.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Gtk/Extra/BuilderTH.hs @@ -0,0 +1,64 @@ +-- | This module allows you to access Glade objects from +-- a Gtk Builder by providing the builder, the type of the +-- object and the name (the cast operation is deduced +-- automatically from the type name). +-- +-- It uses Graphics.UI.Gtk.Builder.onBuilder to access a +-- glade object using TH. + +module Graphics.UI.Gtk.Extra.BuilderTH + ( gtkBuilderAccessor + , gtkViewAccessor + , fromBuilder + ) + where + +import Graphics.UI.Gtk.Extra.Builder (fromBuilder) +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib + +-- | Accessor for Glade objects from Gtk Builders by name and +-- type. +gtkBuilderAccessor :: String -> String -> Q [Dec] +gtkBuilderAccessor name kind = sequenceQ + -- Declaration + [ sigD funcName + -- Builder -> IO Kind + (appT (appT arrowT (conT (mkName "Builder"))) + (appT (conT (mkName "IO")) (conT (mkName kind)))) + -- Implementation + , funD funcName + -- castedOnBuilder objectName + [clause [] (normalB (appE castedAccess + (litE (stringL name)))) []] + ] + + where castedAccess = appE (varE (mkName "fromBuilder")) casting + casting = varE (mkName ("castTo" ++ kind)) + funcName = mkName name + +-- | Accessor for Glade objects from Gtk Builders encapsulated in +-- Views, by name and -- type. +gtkViewAccessor :: String -> String -> String -> String -> Q [Dec] +gtkViewAccessor builderModule uiAccessor name kind = sequenceQ + -- Declaration + [ sigD funcName + -- Builder -> IO Kind + (appT (appT arrowT (conT (mkName "View"))) + (appT (conT (mkName "IO")) (conT (mkName kind)))) + -- Implementation + , funD funcName + -- castedOnBuilder objectName + [clause [varP builderName] + (normalB (appE (varE funcNameInBuilder) + (appE (varE (mkName uiAccessor)) + (varE builderName) + ) + )) []] + ] + + where castedAccess = appE (varE (mkName "fromBuilder")) casting + casting = varE (mkName ("castTo" ++ kind)) + funcName = mkName name + funcNameInBuilder = mkName $ builderModule ++ ('.' : name) + builderName = mkName "b" diff --git a/src/Graphics/UI/Gtk/Helpers/Combo.hs b/src/Graphics/UI/Gtk/Helpers/Combo.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Gtk/Helpers/Combo.hs @@ -0,0 +1,44 @@ +module Graphics.UI.Gtk.Helpers.Combo where + +import Data.List +import Data.Maybe +import Graphics.UI.Gtk + +addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model) + => ComboBox -> model row -> (row -> Maybe String) -> IO() +addTextColumn cb st f = do + + comboBoxSetModel cb (Just st) + renderer <- cellRendererTextNew + cellLayoutPackStart cb renderer True + cellLayoutSetAttributes cb renderer st $ map (cellText :=).maybeToList.f + return () + +type TypedComboBox a = (ComboBox, ListStore a) + +typedComboBoxCombo :: TypedComboBox a -> ComboBox +typedComboBoxCombo = fst + +typedComboBoxStore :: TypedComboBox a -> ListStore a +typedComboBoxStore = snd + +typedComboBoxGetSelected :: TypedComboBox a -> IO (Maybe a) +typedComboBoxGetSelected (cb, ls) = do + sel <- get cb comboBoxActive + list <- listStoreToList ls + if sel < 0 || length list <= sel + then return Nothing + else return $ Just $ list!!sel + +typedComboBoxGetSelectedUnsafe :: TypedComboBox a -> IO a +typedComboBoxGetSelectedUnsafe (cb, ls) = do + sel <- get cb comboBoxActive + list <- listStoreToList ls + return $ list!!sel + +typedComboBoxSetSelected :: (Eq a) => TypedComboBox a -> a -> IO () +typedComboBoxSetSelected (cb, ls) x = do + list <- listStoreToList ls + case elemIndex x list of + Nothing -> return () + Just ix -> set cb [ comboBoxActive := ix ] diff --git a/src/System/Application.hs b/src/System/Application.hs new file mode 100644 --- /dev/null +++ b/src/System/Application.hs @@ -0,0 +1,17 @@ +module System.Application where + +-- External imports +import Control.Monad +-- import Control.Monad.Extra +import System.GIO.File.AppInfo +import System.Process + +-- FIXME: This uses runProcess instead of appInfoLaunchUris because +-- the latter segfaults in my machine +openUrlBySystemTool :: String -> IO Bool +openUrlBySystemTool url = do + infos <- appInfoGetAllForType "text/html" + unless (null infos) $ void $ do + let exe = appInfoGetExecutable $ head infos + runProcess exe [url] Nothing Nothing Nothing Nothing Nothing + return (not (null infos)) diff --git a/tests/HaddockCoverage.hs b/tests/HaddockCoverage.hs new file mode 100644 --- /dev/null +++ b/tests/HaddockCoverage.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (HaddockCoverage) +-- Copyright : (C) 2015 Ivan Perez +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Ivan Perez +-- Stability : provisional +-- Portability : portable +-- +-- Copyright notice: This file borrows code +-- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc +-- which is itself licensed BSD-style as well. +-- +-- Run haddock on a source tree and report if anything in any +-- module is not documented. +----------------------------------------------------------------------------- +module Main where + +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Regex.Posix + +main :: IO () +main = do + -- Find haskell modules + -- TODO: Ideally cabal should do this (provide us with the + -- list of modules). An alternative would be to use cabal haddock + -- but that would need a --no-html argument or something like that. + -- Alternatively, we could use cabal haddock with additional arguments. + -- + -- See: + -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495 + -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929 + files <- getSources + + let haddockArgs = [ "--no-warnings", "--ignore-all-exports" ] ++ files + let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs + (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs "" + + -- Filter out coverage lines, and find those that denote undocumented + -- modules. + -- + -- TODO: is there a way to annotate a function as self-documenting, + -- in the same way we do with ANN for hlint? + let isIncompleteModule :: String -> Bool + isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%") + where isCoverageLine :: String -> Bool + isCoverageLine line = line =~ "^ *[0-9]+%" + + let incompleteModules :: [String] + incompleteModules = filter isIncompleteModule $ lines out + + -- Based on the result of haddock, report errors and exit. + -- Note that, unline haddock, this script does not + -- output anything to stdout. It uses stderr instead + -- (as it should). + case (code, incompleteModules) of + (ExitSuccess , []) -> return () + -- (ExitFailure _, _) -> exitFailure + (_ , _) -> do + hPutStrLn stderr "The following modules are not fully documented:" + mapM_ (hPutStrLn stderr) incompleteModules + exitFailure + +getSources :: IO [FilePath] +getSources = filter isHaskellFile <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + + isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) + && not (any (`isSuffixOf` fp) excludedFiles) + + excludedFiles = [ ] + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +-- find-based implementation (not portable) +-- +-- getSources :: IO [FilePath] +-- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] "" diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module runs HLint on the lens source tree. +----------------------------------------------------------------------------- +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ ["src", "--cross", "--hint=tests/HLint.hs" ] ++ args + unless (null hints) exitFailure