glib-stopgap (empty) → 0.1.0.0

raw patch · 16 files changed

+432/−0 lines, 16 filesdep +basedep +c-enumdep +glib-stopgapsetup-changed

Dependencies added: base, c-enum, glib-stopgap, primitive, text

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• glib-stopgap.cabal +67/−0
• src/Foreign/Ptr/Misc.hs +9/−0
• src/System/GLib/Bool.hsc +16/−0
• src/System/GLib/DoublyLinkedLists.hsc +69/−0
• src/System/GLib/ErrorReporting.hsc +32/−0
• src/System/GLib/GObject.hs +5/−0
• src/System/GLib/Pointerable.hs +16/−0
• src/System/GLib/Quarks.hs +7/−0
• src/System/GLib/Quarks/Internal.hsc +55/−0
• src/System/GLib/SimpleXmlSubsetParser.hsc +93/−0
• src/System/GLib/SinglyLinkedLists.hsc +25/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for glib-stopgap++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++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 Author name here 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.

@@ -0,0 +1,1 @@+# glib-stopgap

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,67 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           glib-stopgap+version:        0.1.0.0+synopsis:       Stopgap package of binding for GLib+description:    Please see the README on GitHub at <https://github.com/githubuser/glib-stopgap#readme>+category:       System+homepage:       https://github.com/githubuser/glib-stopgap#readme+bug-reports:    https://github.com/githubuser/glib-stopgap/issues+author:         Author name here+maintainer:     example@example.com+copyright:      2021 Author name here+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/githubuser/glib-stopgap++library+  exposed-modules:+      Foreign.Ptr.Misc+      System.GLib.Bool+      System.GLib.DoublyLinkedLists+      System.GLib.ErrorReporting+      System.GLib.GObject+      System.GLib.Pointerable+      System.GLib.Quarks+      System.GLib.Quarks.Internal+      System.GLib.SimpleXmlSubsetParser+      System.GLib.SinglyLinkedLists+  other-modules:+      Paths_glib_stopgap+  hs-source-dirs:+      src+  pkgconfig-depends:+      glib-2.0+  build-depends:+      base >=4.7 && <5+    , c-enum+    , primitive+    , text+  default-language: Haskell2010++test-suite glib-stopgap-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_glib_stopgap+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , c-enum+    , glib-stopgap+    , primitive+    , text+  default-language: Haskell2010

@@ -0,0 +1,9 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Ptr.Misc where++import Foreign.Ptr++pattern NullPtr :: Ptr a+pattern NullPtr <- ((== nullPtr) -> True) where NullPtr = nullPtr

@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.Bool (gbooleanToBool, boolToGboolean) where++import Data.Int++#include <glib.h>++gbooleanToBool :: #{type gboolean} -> Bool+gbooleanToBool #{const FALSE} = False+gbooleanToBool #{const TRUE} = True+gbooleanToBool _ = error "bad gboolean"++boolToGboolean :: Bool -> #{type gboolean}+boolToGboolean False = #{const FALSE}+boolToGboolean True = #{const TRUE}

@@ -0,0 +1,69 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.DoublyLinkedLists (+	-- * TYPE+	GList,++	-- * LIST+	g_list_to_list, g_list_to_prev_next_lists,++	-- * POINTER+	g_list_prev_data_next, g_list_data, g_list_prev, g_list_next,++	-- * FREE+	c_g_list_free ) where++import Foreign.Ptr+import Foreign.Ptr.Misc+import Foreign.Storable++#include <glib.h>++data GList a++g_list_to_list :: Ptr (GList a) -> IO (Maybe [Ptr a])+g_list_to_list = ((uncurry appendReverse <$>) <$>) . g_list_to_prev_next_lists++appendReverse :: [a] -> [a] -> [a]+[] `appendReverse` ys = ys+(x : xs) `appendReverse` ys = xs `appendReverse` (x : ys)++g_list_to_prev_next_lists :: Ptr (GList a) -> IO (Maybe ([Ptr a], [Ptr a]))+g_list_to_prev_next_lists = \case+	NullPtr -> pure Nothing+	p -> Just <$> (+		(,)	<$> (g_list_to_prev_list =<< #{peek GList, prev} p)+			<*> g_list_to_next_list p )++g_list_to_prev_list :: Ptr (GList a) -> IO [Ptr a]+g_list_to_prev_list = \case+	NullPtr -> pure []+	p -> (:)+		<$> #{peek GList, data} p+		<*> (g_list_to_prev_list =<< #{peek GList, prev} p)++g_list_to_next_list :: Ptr (GList a) -> IO [Ptr a]+g_list_to_next_list = \case+	NullPtr -> pure []+	p -> (:)+		<$> #{peek GList, data} p+		<*> (g_list_to_next_list =<< #{peek GList, next} p)++g_list_prev_data_next ::+	Ptr (GList a) -> IO (Maybe (Ptr (GList a), Ptr a, Ptr (GList a)))+g_list_prev_data_next = \case+	NullPtr -> pure Nothing+	p -> (Just <$>) $ (,,)+		<$> #{peek GList, prev} p+		<*> #{peek GList, data} p+		<*> #{peek GList, next} p++g_list_data :: Ptr (GList a) -> IO (Maybe (Ptr a))+g_list_data = \case NullPtr -> pure Nothing; p -> Just <$> #{peek GList, data} p++g_list_prev, g_list_next :: Ptr (GList a) -> IO (Maybe (Ptr (GList a)))+g_list_prev = \case NullPtr -> pure Nothing; p -> Just <$> #{peek GList, prev} p+g_list_next = \case NullPtr -> pure Nothing; p -> Just <$> #{peek GList, next} p++foreign import ccall "g_list_free" c_g_list_free :: Ptr (GList a) -> IO ()

@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.ErrorReporting (+	GError(..), mkGError, gErrorReport+	) where++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types+import Foreign.C.String++import System.GLib.Quarks++#include <glib.h>++data GError = GError {+	gErrorDomain :: GQuark, gErrorCode :: CInt, gErrorMessage :: String }+	deriving Show++mkGError :: Ptr GError -> IO GError+mkGError p = do+	ge <- GError+		<$> #{peek GError, domain} p+		<*> #{peek GError, code} p+		<*> (peekCString =<< #{peek GError, message} p)+	c_g_error_free p+	pure ge++foreign import ccall "g_error_free" c_g_error_free :: Ptr GError -> IO ()++gErrorReport :: GError -> String+gErrorReport (GError d c m) = gQuarkToString d ++ ": " ++ show c ++ ": " ++ m

@@ -0,0 +1,5 @@+module System.GLib.GObject where++import Foreign.Ptr++foreign import ccall "g_object_unref" c_g_object_unref :: Ptr a -> IO ()

@@ -0,0 +1,16 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.Pointerable (Pointerable(..)) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable++class Pointerable a where+	withPtr :: a -> (Ptr a -> IO b) -> IO b; fromPtr :: Ptr a -> IO a++instance {-# OVERLAPPABLE #-} Storable a => Pointerable a where+	withPtr x f = alloca \p -> poke p x >> f p+	fromPtr = peek

@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.Quarks (+	GQuark,+	gQuarkFromString, gQuarkToString, gInternString, gUninternString ) where++import System.GLib.Quarks.Internal

@@ -0,0 +1,55 @@+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.Quarks.Internal (+	GQuark(..),+	gQuarkFromString, gQuarkToString, gInternString, gUninternString,+	gQuarkTryString ) where++import Foreign.Storable+import Foreign.C.String+import Data.Word++import System.IO.Unsafe++#include <gmodule.h>++newtype GQuark = GQuark #{type GQuark} deriving (Eq, Storable)++instance Show GQuark where show _ = "GQuark"++gQuarkFromString :: String -> GQuark+gQuarkFromString s =+	unsafePerformIO $ GQuark <$> withCString s c_g_quark_from_string++foreign import ccall "g_quark_from_string" c_g_quark_from_string ::+	CString -> IO #{type GQuark}++gQuarkToString :: GQuark -> String+gQuarkToString (GQuark q) =+	unsafePerformIO $ peekCString =<< c_g_quark_to_string q++foreign import ccall "g_quark_to_string" c_g_quark_to_string ::+	#{type GQuark} -> IO CString++gQuarkTryString :: String -> IO (Maybe GQuark)+gQuarkTryString s = (<$> withCString s c_g_quark_try_string) \case+		0 -> Nothing; q -> Just $ GQuark q++foreign import ccall "g_quark_try_string" c_g_quark_try_string ::+	CString -> IO #{type GQuark}++newtype InternedString = InternedString CString deriving Eq++instance Show InternedString where show _ = "InternedString"++gInternString :: String -> InternedString+gInternString s =+	unsafePerformIO $ InternedString <$> withCString s c_g_intern_string++gUninternString :: InternedString -> String+gUninternString (InternedString i) = unsafePerformIO $ peekCString i++foreign import ccall "g_intern_string" c_g_intern_string ::+	CString -> IO CString

@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.SimpleXmlSubsetParser (+	-- * TYPE+	GMarkupParseContext(..), mkGMarkupParseContext,++	-- * FUNCTION+	gMarkupParseContextParse,++	-- * G MARKUP ERROR+	pattern GErrorMarkup,+	pattern GMarkupErrorBadUtf8,+	pattern GMarkupErrorEmpty,+	pattern GMarkupErrorParse,+	pattern GMarkupErrorUnknownElement,+	pattern GMarkupErrorUnknownAttribute,+	pattern GMarkupErrorInvalidContent,+	pattern GMarkupErrorMissingAttribute+	) where++import Foreign.Ptr+import Foreign.ForeignPtr hiding (newForeignPtr)+import Foreign.Concurrent+import Foreign.Marshal+import Foreign.Storable+import Foreign.C.String+import Foreign.C.Enum+import Control.Monad.Primitive+import Data.Word+import Data.Int+import System.GLib.ErrorReporting+import System.GLib.Quarks.Internal++import System.IO.Unsafe++import qualified Data.Text as T+import qualified Data.Text.Foreign as T++#include <glib.h>++newtype GMarkupParseContext s =+	GMarkupParseContext (ForeignPtr (GMarkupParseContext s)) deriving Show++mkGMarkupParseContext :: Ptr (GMarkupParseContext s) -> IO (GMarkupParseContext s)+mkGMarkupParseContext p = GMarkupParseContext+	<$> newForeignPtr p (c_g_markup_parse_context_free p)++foreign import ccall "g_markup_parse_context_free"+	c_g_markup_parse_context_free :: Ptr (GMarkupParseContext s) -> IO ()++gMarkupParseContextParse :: PrimMonad m =>+	GMarkupParseContext (PrimState m) -> T.Text -> m (Either GError ())+gMarkupParseContextParse (GMarkupParseContext fpc) t = unsafeIOToPrim+	$ withForeignPtr fpc \ppc -> T.withCStringLen t \(ct, ctl) -> alloca \pge -> do+		r <- c_g_markup_parse_context_parse ppc ct (fromIntegral ctl) pge+		case r of+			#{const FALSE} -> Left <$> (mkGError =<< peek pge)+			#{const TRUE} -> pure $ Right ()+			_ -> error "never occur"++foreign import ccall "g_markup_parse_context_parse"+	c_g_markup_parse_context_parse ::+	Ptr (GMarkupParseContext s) -> CString -> #{type gssize} ->+	Ptr (Ptr GError) -> IO #{type gboolean}++enum "GMarkupError" ''#{type GMarkupError} [''Show] [+	("GMarkupErrorBadUtf8", #{const G_MARKUP_ERROR_BAD_UTF8}),+	("GMarkupErrorEmpty", #{const G_MARKUP_ERROR_EMPTY}),+	("GMarkupErrorParse", #{const G_MARKUP_ERROR_PARSE}),+	("GMarkupErrorUnknownElement", #{const G_MARKUP_ERROR_UNKNOWN_ELEMENT}),+	("GMarkupErrorUnknownAttribute",+		#{const G_MARKUP_ERROR_UNKNOWN_ATTRIBUTE}),+	("GMarkupErrorInvalidContent", #{const G_MARKUP_ERROR_INVALID_CONTENT}),+	("GMarkupErrorMissingAttribute",+		#{const G_MARKUP_ERROR_MISSING_ATTRIBUTE}) ]++pattern GErrorMarkup :: GMarkupError -> String -> GError+pattern GErrorMarkup c m <- (gErrorMarkup -> Just (c, m)) where+	GErrorMarkup (GMarkupError c) m =+		GError gMarkupErrorGQuark (fromIntegral c) m++gErrorMarkup :: GError -> Maybe (GMarkupError, String)+gErrorMarkup (GError d c m)+	| d == gMarkupErrorGQuark = Just (GMarkupError $ fromIntegral c, m)+	| otherwise = Nothing++gMarkupErrorGQuark :: GQuark+gMarkupErrorGQuark = unsafePerformIO c_g_markup_error_quark++foreign import ccall "g_markup_error_quark" c_g_markup_error_quark :: IO GQuark

@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.GLib.SinglyLinkedLists (GSList, g_slist_to_list, g_slist_to_list') where++import Foreign.Ptr+import Foreign.ForeignPtr hiding (newForeignPtr)+import Foreign.Storable++#include <glib.h>++newtype GSList a = GSList (ForeignPtr (GSList a)) deriving Show++foreign import ccall "g_slist_free" c_g_slist_free :: Ptr (GSList a) -> IO ()++g_slist_uncons :: Ptr (GSList a) -> IO (Ptr a, Ptr (GSList a))+g_slist_uncons p = (,) <$> #{peek GSList, data} p <*> #{peek GSList, next} p++g_slist_to_list, g_slist_to_list' :: Ptr (GSList a) -> IO [Ptr a]+g_slist_to_list lst+	| lst == nullPtr = pure []+	| otherwise = do+		(p, lst') <- g_slist_uncons lst+		(p :) <$> g_slist_to_list lst'++g_slist_to_list' lst = g_slist_to_list lst <* c_g_slist_free lst

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"