packages feed

hexchat (empty) → 0.0.1.0

raw patch · 7 files changed

+998/−0 lines, 7 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, ghc, ghc-paths, ghc-prim, ghci, hexchat

Files

+ HexChat.hs view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -fno-warn-tabs #-}+{-|+Module      : HexChat+Description : HexChat scripting interface+Copyright   : (C) 2017 mniip+License     : MIT+Maintainer  : mniip@mniip.com+Stability   : none+Portability : none++A HexChat script is a @.hs@ file that defines a global identifier @info@ with type 'ModInfo'. This structure contains the necessary metadata about a script as well its initialization and deinitialization functions. From your initialization function you may want to hook some events. Any remaining hooks are automatically unhooked after the deinitializer so you don't have to worry about that.+-}+module HexChat+	(+		-- * Module Info+		ModInfo(..), modInfo,++		-- * Interfacing HexChat+		command,+		print,+		emitPrint,+		EventAttrs(..),+		emitPrintAttrs,+		sendModes,+		nickCmp,+		strip,+		getPrefs,+		getPrefString,+		getPrefInt,+		getPrefBool,+		List,+		listGet,+		listFields,+		listNext,+		listStr,+		listInt,+		listTime,++		-- * Hooks+		-- | All hooks have a priority that determines the order in which HexChat invokes them. Each hook can also affect the propagation of the event to other hooks.+		I.pri_HIGHEST, I.pri_HIGH, I.pri_NORM, I.pri_LOW, I.pri_LOWEST,+		Eat(..),+		Hook,+		hookCommand,+		hookPrint,+		hookPrintAttrs,+		hookServer,+		hookServerAttrs,+		unhook,++		-- * Contexts+		-- | Some HexChat interface functions are specific to a given 'Context', which corresponds to a tab or window. By default whenever a hook is invoked it is running in the event's relevant context. If you need to output text or commands to a different tab you should change the context.+		Context,+		findContext,+		getContext,+		setContext,+		withContext+	)+	where++import Prelude hiding (print)++import Control.Exception+import Control.Monad+import Data.IORef+import Foreign.C.Types++import HexChat.Internal (StaticData, staticData, lHooks, getPlugin, getHandle, withHandle, Hook, Eat(..), EventAttrs(..), Context, List)+import qualified HexChat.Internal as I++-- | This datatype contains metadata about the script. Every script should define an global binding named @info@ of this type. This structure contains internal fields necessary for scripting to work, so when constructing an object please use the default value 'modInfo' with record modification notation, like this:+--+-- @+-- info = 'modInfo' { 'modName' = "a module", 'modAuthor' = "somepony", ... }+-- @+--+-- The type parameter signifies the return type of the initializer and has no special meaning otherwise, you can specialize it to anything you want.+--+-- If you need to pass a lot of data to the deinitializer you could simply let @a ~ IO ()@ and @'modDeinit' = id@, such as in the following:+--+-- @+-- info = 'modInfo'+--     { 'modInit' = do+--           x <- createX+--           'return' $ do+--               destroyX x+--     , 'modDeinit' = 'id'+--     }+-- @+data ModInfo a = ModInfo+	{+		modName :: String, -- ^ Name of the script.+		modVersion :: String, -- ^ Version of the script.+		modAuthor :: String, -- ^ Author of the script.+		modDescription :: String, -- ^ A short description of the script that can fit in the "Plugins and Scripts" list window.+		modInit :: IO a, -- ^ This is the entry point of the script. It will be executed immediately after the script is compiled and loaded. The returned value will be opaquely passed to 'modDeinit'.+		modDeinit :: a -> IO (), -- ^ This function will be executed shortly before the script is unloaded. You can place any cleanup routines here. As argument it receives whatever 'modInit' returned.+		modStaticData :: StaticData -- ^ An internal field that lets the different (to the linker) instances of the HexChat library identify eachother. Please inherit the value of this field from 'modInfo'.+	}++-- | A default value for 'ModInfo'. This has some sensible defaults and also provides the values of internal fields necessary for the operation of the interface.+modInfo :: ModInfo a+modInfo = ModInfo+	{+		modName = "module",+		modVersion = "",+		modAuthor = "",+		modDescription = "No description provided",+		modInit = return $ error "modInit",+		modDeinit = \_ -> return (),+		modStaticData = staticData+	}++-- | Invoke a HexChat command as if the user has typed it in the inputbox. Do not include the leading @/@.+command :: String -> IO ()+command str = do+	plugin <- getPlugin+	I.command plugin str++-- | Print some text to the buffer.+print :: String -> IO ()+print str = do+	plugin <- getPlugin+	I.print plugin str++-- | Output a Text Event to the buffer. First argument is the Text Event identifier (see @Settings -> Text Events@), second is the list of event's parameters.+emitPrint :: String -> [String] -> IO Bool+emitPrint event vs = do+	plugin <- getPlugin+	I.emitPrint plugin event vs++-- | Same as 'emitPrint' but also lets you specify Event Attributes for the event.+emitPrintAttrs :: EventAttrs -> String -> [String] -> IO Bool+emitPrintAttrs attrs event vs = do+	plugin <- getPlugin+	I.emitPrintAttrs plugin attrs event vs++-- | @'sendModes' targets n sign mode@ where @sign@ is @+@ or @-@ and @mode@ is a channel mode character will set the specified channel mode on each of the specified targets, sending @n@ modes per line, or the server's advertised maximum if @n@ is zero.+sendModes :: [String] -> Int -> Char -> Char -> IO ()+sendModes targets modes sign mode = do+	plugin <- getPlugin+	I.sendModes plugin targets modes sign mode++-- this should really be 'IO (String -> String -> Ordering)' but the underlying C API wouldn't let you easily do that...+-- | Compare two nicknames according to the rules of the server.+nickCmp :: String -> String -> IO Ordering+nickCmp s1 s2 = do+	plugin <- getPlugin+	I.nickCmp plugin s1 s2++-- | @'strip' colors format@ will strip colors if @colors@ is 'True', and miscellaneous formatting if @formatting@ is 'True', from the provided string.+strip :: Bool -> Bool -> String -> IO String+strip sc sf str = do+	plugin <- getPlugin+	I.strip plugin sc sf str++-- | Get a HexChat preference value (see @/set@). You should pass 3 continuations one of which will be invoked depending on the type of the actual preference. Returns 'Nothing' if no preference with that name exists.+getPrefs :: String -> (String -> IO a) -> (Int -> IO a) -> (Bool -> IO a) -> IO (Maybe a)+getPrefs key cstr cint cbool = do+	plugin <- getPlugin+	I.getPrefs plugin key cstr cint cbool++-- | Return the value of a preference that is supposedly a String. Returns 'Nothing' if no such preference exists or it is of the wrong type.+getPrefString :: String -> IO (Maybe String)+getPrefString key = join <$> getPrefs key (return . Just) (const $ return Nothing) (const $ return Nothing)++-- | Return the value of a preference that is supposedly an Int. Returns 'Nothing' if no such preference exists or it is of the wrong type.+getPrefInt :: String -> IO (Maybe Int)+getPrefInt key = join <$> getPrefs key (const $ return Nothing) (return . Just) (const $ return Nothing)++-- | Return the value of a preference that is supposedly a Bool. Returns 'Nothing' if no such preference exists or it is of the wrong type.+getPrefBool :: String -> IO (Maybe Bool)+getPrefBool key = join <$> getPrefs key (const $ return Nothing) (const $ return Nothing) (return . Just)++listGet :: String -> IO (Maybe List)+listGet key = do+	plugin <- getPlugin+	I.listGet plugin key++listFields :: String -> IO [String]+listFields key = do+	plugin <- getPlugin+	I.listFields plugin key++listNext :: List -> IO Bool+listNext list = do+	plugin <- getPlugin+	I.listNext plugin list++listStr :: List -> String -> IO String+listStr list key = do+	plugin <- getPlugin+	I.listStr plugin list key++listInt :: List -> String -> IO Int+listInt list key = do+	plugin <- getPlugin+	I.listInt plugin list key++listTime :: List -> String -> IO CTime+listTime list key = do+	plugin <- getPlugin+	I.listTime plugin list key++-- | @'hookCommand' cmd priority description f@ registers a command named @cmd@ (with description @description@). The given @f@ will be passed a list of command's arguments (proper words) and a list of "leftovers" for every position in the word list (with the exact original whitespace).+--+-- If @cmd@ is @""@ then instead the hook will be invoked whenever the user types anything not beginning with @/@.+hookCommand :: String -> CInt -> String -> ([String] -> [String] -> IO Eat) -> IO Hook+hookCommand cmd pri desc f = do+	plugin <- getPlugin+	handle <- getHandle+	hook <- I.hookCommand plugin cmd pri desc $ \w we -> withHandle handle $ f w we+	readIORef lHooks >>= flip modifyIORef ((handle, hook) :)+	return hook++-- | @'hookPrint' event priority f@ hooks @f@ to be invoked whenever a Text Event @event@ is to be displayed on screen. The given @f@ will be passed a list of event's parameters.+hookPrint :: String -> CInt -> ([String] -> IO Eat) -> IO Hook+hookPrint cmd pri f = do+	plugin <- getPlugin+	handle <- getHandle+	hook <- I.hookPrint plugin cmd pri $ \w -> withHandle handle $ f w+	readIORef lHooks >>= flip modifyIORef ((handle, hook) :)+	return hook++-- | @'hookPrintAttrs' event priority f@ hooks @f@ to be invoked whenever a Text Event @event@ is to be displayed on screen. The given @f@ will be passed a list of event's parameters, and the attributes.+hookPrintAttrs :: String -> CInt -> ([String] -> EventAttrs -> IO Eat) -> IO Hook+hookPrintAttrs cmd pri f = do+	plugin <- getPlugin+	handle <- getHandle+	hook <- I.hookPrintAttrs plugin cmd pri $ \w attrs -> withHandle handle $ f w attrs+	readIORef lHooks >>= flip modifyIORef ((handle, hook) :)+	return hook++-- | @'hookServer' word priority f@ hooks @f@ to be invoked whenever a @word@ command arrives from the IRC server. The given @f@ will be passed a list of command's arguments (proper words) and a list of "leftovers" for every position in the word list (with the exact original whitespace). Processing of @:@ long arguments is *NOT* done.+--+-- If @cmd@ is @"RAW LINE"@ then the hook will be invoked for all commands received from the server.+hookServer :: String -> CInt -> ([String] -> [String] -> IO Eat) -> IO Hook+hookServer cmd pri f = do+	plugin <- getPlugin+	handle <- getHandle+	hook <- I.hookServer plugin cmd pri $ \w we -> withHandle handle $ f w we+	readIORef lHooks >>= flip modifyIORef ((handle, hook) :)+	return hook++-- | @'hookServer' word priority f@ hooks @f@ to be invoked whenever a @word@ command arrives from the IRC server. The given @f@ will be passed a list of command's arguments (proper words), a list of "leftovers" for every position in the word list (with the exact original whitespace), and the event attributes. Processing of @:@ long arguments is *NOT* done.+--+-- If @cmd@ is @"RAW LINE"@ then the hook will be invoked for all commands received from the server.+hookServerAttrs :: String -> CInt -> ([String] -> [String] -> EventAttrs -> IO Eat) -> IO Hook+hookServerAttrs cmd pri f = do+	plugin <- getPlugin+	handle <- getHandle+	hook <- I.hookServerAttrs plugin cmd pri $ \w we attrs -> withHandle handle $ f w we attrs+	readIORef lHooks >>= flip modifyIORef ((handle, hook) :)+	return hook++-- | Remove the given hook. All hooks are automatically removed when the script is unloaded.+unhook :: Hook -> IO ()+unhook hook = do+	plugin <- getPlugin+	readIORef lHooks >>= flip modifyIORef (filter ((/= hook) . snd))+	I.unhook plugin hook++-- | @'findContext' mserver mtabname@ finds the context corresponding to the given tab name (or to the front tab if 'Nothing') in the given server (or in any of the servers if 'Nothing').+findContext :: Maybe String -> Maybe String -> IO (Maybe Context)+findContext server channel = do+	plugin <- getPlugin+	I.findContext plugin server channel++-- | Obtains the current context.+getContext :: IO Context+getContext = do+	plugin <- getPlugin+	I.getContext plugin++-- | Sets the current context. The scope of this function is limited to the currently executing hook (or the initializer/deinitializer).+setContext :: Context -> IO Bool+setContext context = do+	plugin <- getPlugin+	I.setContext plugin context++-- | Execute a given IO action in a given context a-la 'bracket'.+withContext :: Context -> IO a -> IO a+withContext context f = bracket (swap context) swap (const f)+	where swap context = do+		old <- getContext+		b <- setContext context+		unless b $ error "Could not set context"+		return old
+ HexChat/Internal.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE CApiFFI #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}+{-|+Module      : HexChat.Internal+Description : HexChat scripting interface+Copyright   : (C) 2017 mniip+License     : MIT+Maintainer  : mniip@mniip.com+Stability   : none+Portability : none++This module contains the "raw" functions that leak the fact that all Haskell scripts are actually executed under the same @hexchat_plugin@ structure. You should unhook everything you have hooked.+-}++module HexChat.Internal+	(+		pri_HIGHEST, pri_HIGH, pri_NORM, pri_LOW, pri_LOWEST,+		Hook, Eat(..), EventAttrs(..), Context, List,++		command,+		print,+		emitPrint,+		emitPrintAttrs,+		sendModes,+		nickCmp,+		strip,+		getPrefs,+		listGet,+		listFields,+		listNext,+		listStr,+		listInt,+		listTime,+		hookCommand,+		hookPrint,+		hookPrintAttrs,+		hookServer,+		hookServerAttrs,+		unhook,+		findContext,+		getContext,+		setContext,+		pluginguiAdd,+		pluginguiRemove,++		StaticData,+		staticData,+		lPlugin, lHandle, lHooks,+		initStaticData,+		joinStaticData,+		getPlugin,+		getHandle,+		withHandle,+		unhookHandle,++		module Foreign.C.Types,+		Plugin(..),+		Plugin_Init(..),+		Plugin_Deinit(..)+	)+	where++import Prelude hiding (print)++import Control.Monad+import Control.Exception+import Data.Coerce+import Data.IORef+import Foreign+import Foreign.C.Types+import Foreign.C.String+import GHC.StaticPtr+import System.IO.Unsafe++data HexChat_Plugin+newtype Plugin = Plugin (Ptr HexChat_Plugin) deriving (Show, Eq, Ord)+data HexChat_Hook+-- | An opaque type referencing a particular hook. Can be passed to 'HexChat.unhook'.+newtype Hook = Hook (Ptr HexChat_Hook) deriving (Show, Eq, Ord)+data HexChat_Context+-- | An opaque type referencing a context (tab or window).+newtype Context = Context (Ptr HexChat_Context) deriving (Show, Eq, Ord)+data HexChat_List+data List = List (IORef Bool) (ForeignPtr HexChat_List) deriving (Eq)+data HexChat_EventAttrs++foreign import capi "hexchat-plugin.h value HEXCHAT_PRI_HIGHEST" pri_HIGHEST :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_PRI_HIGH" pri_HIGH :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_PRI_NORM" pri_NORM :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_PRI_LOW" pri_LOW :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_PRI_LOWEST" pri_LOWEST :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_EAT_NONE" eat_NONE :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_EAT_HEXCHAT" eat_HEXCHAT :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_EAT_PLUGIN" eat_PLUGIN :: CInt+foreign import capi "hexchat-plugin.h value HEXCHAT_EAT_ALL" eat_ALL :: CInt++foreign import capi "hexchat-plugin.h hexchat_command" hexchat_command :: Plugin -> CString -> IO ()+foreign import capi "hexchat-plugin.h hexchat_print" hexchat_print :: Plugin -> CString -> IO ()+foreign import capi "hexchat-plugin.h hexchat_emit_print" hexchat_emit_print :: Plugin -> CString -> CString -> CString -> CString -> CString -> CString -> IO Bool+foreign import capi "hexchat-plugin.h hexchat_emit_print_attrs" hexchat_emit_print_attrs :: Plugin -> Ptr HexChat_EventAttrs -> CString -> CString -> CString -> CString -> CString -> CString -> IO Bool+foreign import capi "hexchat-plugin.h hexchat_send_modes" hexchat_send_modes :: Plugin -> Ptr CString -> CInt -> CInt -> CChar -> CChar -> IO ()+foreign import capi "hexchat-plugin.h hexchat_nickcmp" hexchat_nickcmp :: Plugin -> CString -> CString -> IO CInt+foreign import capi "hexchat-plugin.h hexchat_strip" hexchat_strip :: Plugin -> CString -> CInt -> CInt -> IO CString+foreign import capi "hexchat-plugin.h hexchat_free" hexchat_free :: Plugin -> Ptr a -> IO ()+foreign import capi "hexchat-plugin.h hexchat_event_attrs_create" hexchat_event_attrs_create :: Plugin -> IO (Ptr HexChat_EventAttrs)+foreign import capi "hexchat-plugin.h hexchat_event_attrs_free" hexchat_event_attrs_free :: Plugin -> Ptr HexChat_EventAttrs -> IO ()+foreign import capi "hexchat-plugin.h hexchat_get_info" hexchat_get_info :: Plugin -> CString -> IO CString+foreign import capi "hexchat-plugin.h hexchat_get_prefs" hexchat_get_prefs :: Plugin -> CString -> Ptr CString -> Ptr CInt -> IO CInt+foreign import capi "hexchat-plugin.h hexchat_list_get" hexchat_list_get :: Plugin -> CString -> IO (Ptr HexChat_List)+foreign import capi "hexchat-plugin.h hexchat_list_fields" hexchat_list_fields :: Plugin -> CString -> IO (Ptr CString)+foreign import capi "hexchat-plugin.h hexchat_list_next" hexchat_list_next :: Plugin -> Ptr HexChat_List -> IO Bool+foreign import capi "hexchat-plugin.h hexchat_list_str" hexchat_list_str :: Plugin -> Ptr HexChat_List -> CString -> IO CString+foreign import capi "hexchat-plugin.h hexchat_list_int" hexchat_list_int :: Plugin -> Ptr HexChat_List -> CString -> IO CInt+foreign import capi "hexchat-plugin.h hexchat_list_time" hexchat_list_time :: Plugin -> Ptr HexChat_List -> CString -> IO CTime+foreign import capi "hexchat-plugin.h hexchat_list_free" hexchat_list_free :: Plugin -> Ptr HexChat_List -> IO ()+foreign import capi "hexchat-plugin.h hexchat_hook_command" hexchat_hook_command :: Plugin -> CString -> CInt -> FunPtr (Ptr CString -> Ptr CString -> StablePtr a -> IO CInt) -> CString -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_hook_print" hexchat_hook_print :: Plugin -> CString -> CInt -> FunPtr (Ptr CString -> StablePtr a -> IO CInt) -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_hook_print_attrs" hexchat_hook_print_attrs :: Plugin -> CString -> CInt -> FunPtr (Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr a -> IO CInt) -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_hook_server" hexchat_hook_server :: Plugin -> CString -> CInt -> FunPtr (Ptr CString -> Ptr CString -> StablePtr a -> IO CInt) -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_hook_server_attrs" hexchat_hook_server_attrs :: Plugin -> CString -> CInt -> FunPtr (Ptr CString -> Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr a -> IO CInt) -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_hook_timer" hexchat_hook_timer :: Plugin -> CInt -> FunPtr (StablePtr a -> IO CInt) -> StablePtr a -> IO Hook+foreign import capi "hexchat-plugin.h hexchat_unhook" hexchat_unhook :: Plugin -> Hook -> IO (StablePtr a)+foreign import capi "hexchat-plugin.h hexchat_find_context" hexchat_find_context :: Plugin -> CString -> CString -> IO Context+foreign import capi "hexchat-plugin.h hexchat_get_context" hexchat_get_context :: Plugin -> IO Context+foreign import capi "hexchat-plugin.h hexchat_set_context" hexchat_set_context :: Plugin -> Context -> IO Bool+foreign import capi "hexchat-plugin.h hexchat_plugingui_add" hexchat_plugingui_add :: Plugin -> CString -> CString -> CString -> CString -> CString -> IO Plugin+foreign import capi "hexchat-plugin.h hexchat_plugingui_remove" hexchat_plugingui_remove :: Plugin -> Plugin -> IO ()++foreign import ccall "&call_haskell_command" ptr_call_haskell_command :: FunPtr (Ptr CString -> Ptr CString -> StablePtr ([String] -> [String] -> IO Eat) -> IO CInt)+foreign export ccall call_haskell_command :: Ptr CString -> Ptr CString -> StablePtr ([String] -> [String] -> IO Eat) -> IO CInt+call_haskell_command pw pwe sf = reportException (return eat_NONE) $ do+	w <- peekStringArray pw 1 32+	we <- peekStringArray pwe 1 32+	f <- deRefStablePtr sf+	fromEat <$> f w we++foreign import ccall "&call_haskell_print" ptr_call_haskell_print :: FunPtr (Ptr CString -> StablePtr ([String] -> IO Eat) -> IO CInt)+foreign export ccall call_haskell_print :: Ptr CString -> StablePtr ([String] -> IO Eat) -> IO CInt+call_haskell_print pw sf = reportException (return eat_NONE) $ do+	ws <- peekStringArray pw 0 4+	f <- deRefStablePtr sf+	fromEat <$> f ws++foreign import ccall "&call_haskell_print_attrs" ptr_call_haskell_print_attrs :: FunPtr (Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr ([String] -> EventAttrs -> IO Eat) -> IO CInt)+foreign export ccall call_haskell_print_attrs :: Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr ([String] -> EventAttrs -> IO Eat) -> IO CInt+call_haskell_print_attrs pw pa sf = reportException (return eat_NONE) $ do+	ws <- peekStringArray pw 0 4+	attrs <- toAttrs pa+	f <- deRefStablePtr sf+	fromEat <$> f ws attrs++foreign import ccall "&call_haskell_server" ptr_call_haskell_server :: FunPtr (Ptr CString -> Ptr CString -> StablePtr ([String] -> [String] -> IO Eat) -> IO CInt)+foreign export ccall call_haskell_server :: Ptr CString -> Ptr CString -> StablePtr ([String] -> [String] -> IO Eat) -> IO CInt+call_haskell_server pw pwe sf = reportException (return eat_NONE) $ do+	w <- peekStringArray pw 1 32+	we <- peekStringArray pwe 1 32+	f <- deRefStablePtr sf+	fromEat <$> f w we++foreign import ccall "&call_haskell_server_attrs" ptr_call_haskell_server_attrs :: FunPtr (Ptr CString -> Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr ([String] -> [String] -> EventAttrs -> IO Eat) -> IO CInt)+foreign export ccall call_haskell_server_attrs :: Ptr CString -> Ptr CString -> Ptr HexChat_EventAttrs -> StablePtr ([String] -> [String] -> EventAttrs -> IO Eat) -> IO CInt+call_haskell_server_attrs pw pwe pa sf = reportException (return eat_NONE) $ do+	w <- peekStringArray pw 1 32+	we <- peekStringArray pwe 1 32+	attrs <- toAttrs pa+	f <- deRefStablePtr sf+	fromEat <$> f w we attrs++foreign import capi "&hexchat_event_attrs_free" ptr_finalize_attrs :: FunPtr (Plugin -> Ptr HexChat_EventAttrs -> IO ())+foreign import capi "&hexchat_list_free" ptr_finalize_list :: FunPtr (Plugin -> Ptr HexChat_List -> IO ())+++-- | This type defines whether the current hook "consumes" the event or lets other hooks know about it.+data Eat = EatNone -- ^ Pass the event to everything else.+	| EatHexChat -- ^ Pass the event to all other scripts but not HexChat.+	| EatPlugin -- ^ Pass the event to HexChat but not any other scripts.+	| EatAll -- ^ Completely consume the event.+	deriving (Show, Read, Eq)++fromEat :: Eat -> CInt+fromEat EatNone = eat_NONE+fromEat EatHexChat = eat_HEXCHAT+fromEat EatPlugin = eat_PLUGIN+fromEat EatAll = eat_ALL++-- | Event attributes.+data EventAttrs = EventAttrs { server_time_utc :: CTime } deriving (Show, Read, Eq)++fromAttrs :: Plugin -> EventAttrs -> IO (ForeignPtr HexChat_EventAttrs)+fromAttrs plugin attrs = do+	ptr <- hexchat_event_attrs_create plugin+	poke (castPtr ptr) (server_time_utc attrs)+	newForeignPtrEnv (coerce ptr_finalize_attrs) (coerce plugin) ptr++withAttrs :: Plugin -> EventAttrs -> (Ptr HexChat_EventAttrs -> IO a) -> IO a+withAttrs plugin attrs f = do+	fp <- fromAttrs plugin attrs+	ret <- withForeignPtr fp f+	finalizeForeignPtr fp+	return ret++toAttrs :: Ptr HexChat_EventAttrs -> IO EventAttrs+toAttrs ptr = EventAttrs <$> peek (castPtr ptr)++peekStringArray :: Ptr CString -> Int -> Int -> IO [String]+peekStringArray ps i j | i >= j = return []+peekStringArray ps i j = do+	p <- peekElemOff ps i+	if p == nullPtr then return []+		else do+			s <- peekCString p+			if null s then return []+				else (s :) <$> peekStringArray ps (i + 1) j++with2CString :: String -> String -> (CString -> CString -> IO a) -> IO a+with2CString a b f = withCString a $ \a -> withCString b $ \b -> f a b++with3CString :: String -> String -> String -> (CString -> CString -> CString -> IO a) -> IO a+with3CString a b c f = withCString a $ \a -> withCString b $ \b -> withCString c $ \c -> f a b c++with4CString :: String -> String -> String -> String -> (CString -> CString -> CString -> CString -> IO a) -> IO a+with4CString a b c d f = withCString a $ \a -> withCString b $ \b -> withCString c $ \c -> withCString d $ \d -> f a b c d++with5CString :: String -> String -> String -> String -> String -> (CString -> CString -> CString -> CString -> CString -> IO a) -> IO a+with5CString a b c d e f = withCString a $ \a -> withCString b $ \b -> withCString c $ \c -> withCString d $ \d -> withCString e $ \e -> f a b c d e++reportException :: IO a -> IO a -> IO a+reportException def f = catch f $ \e -> do+	plugin <- getPlugin+	print plugin $ show (e :: SomeException)+	def+++command :: Plugin -> String -> IO ()+command plugin str = withCString str $ hexchat_command plugin++print :: Plugin -> String -> IO ()+print plugin str = withCString str $ hexchat_print plugin++emitPrint :: Plugin -> String -> [String] -> IO Bool+emitPrint plugin event (v1:v2:v3:v4:_) = with5CString event v1 v2 v3 v4 $ \event v1 v2 v3 v4 -> hexchat_emit_print plugin event v1 v2 v3 v4 nullPtr+emitPrint plugin event [v1, v2, v3] = with4CString event v1 v2 v3 $ \event v1 v2 v3 -> hexchat_emit_print plugin event v1 v2 v3 nullPtr nullPtr+emitPrint plugin event [v1, v2] = with3CString event v1 v2 $ \event v1 v2 -> hexchat_emit_print plugin event v1 v2 nullPtr nullPtr nullPtr+emitPrint plugin event [v1] = with2CString event v1 $ \event v1 -> hexchat_emit_print plugin event v1 nullPtr nullPtr nullPtr nullPtr+emitPrint plugin event [] = withCString event $ \event -> hexchat_emit_print plugin event nullPtr nullPtr nullPtr nullPtr nullPtr++emitPrintAttrs :: Plugin -> EventAttrs -> String -> [String] -> IO Bool+emitPrintAttrs plugin attrs event (v1:v2:v3:v4:_) = withAttrs plugin attrs $ \attrs -> with5CString event v1 v2 v3 v4 $ \event v1 v2 v3 v4 -> hexchat_emit_print_attrs plugin attrs event v1 v2 v3 v4 nullPtr+emitPrintAttrs plugin attrs event [v1, v2, v3] = withAttrs plugin attrs $ \attrs -> with4CString event v1 v2 v3 $ \event v1 v2 v3 -> hexchat_emit_print_attrs plugin attrs event v1 v2 v3 nullPtr nullPtr+emitPrintAttrs plugin attrs event [v1, v2] = withAttrs plugin attrs $ \attrs -> with3CString event v1 v2 $ \event v1 v2 -> hexchat_emit_print_attrs plugin attrs event v1 v2 nullPtr nullPtr nullPtr+emitPrintAttrs plugin attrs event [v1] = withAttrs plugin attrs $ \attrs -> with2CString event v1 $ \event v1 -> hexchat_emit_print_attrs plugin attrs event v1 nullPtr nullPtr nullPtr nullPtr+emitPrintAttrs plugin attrs event [] = withAttrs plugin attrs $ \attrs -> withCString event $ \event -> hexchat_emit_print_attrs plugin attrs event nullPtr nullPtr nullPtr nullPtr nullPtr++sendModes :: Plugin -> [String] -> Int -> Char -> Char -> IO ()+sendModes plugin targets modes sign mode = let len = length targets+	in allocaBytes (sizeOf (undefined :: CString) * length targets) $ \arr -> do+		bracket (mapM newCString targets) (mapM free) $ \strs -> do+			sequence_ $ zipWith (pokeElemOff arr) [0..] strs+			hexchat_send_modes plugin arr (fromIntegral len) (fromIntegral modes) (castCharToCChar sign) (castCharToCChar mode)++nickCmp :: Plugin -> String -> String -> IO Ordering+nickCmp plugin s1 s2 = with2CString s1 s2 $ \s1 s2 -> do+	ret <- hexchat_nickcmp plugin s1 s2+	return $ if ret > 0 then GT else if ret < 0 then LT else EQ++strip :: Plugin -> Bool -> Bool -> String -> IO String+strip plugin sc sf str = withCString str $ \str -> do+	res <- hexchat_strip plugin str (-1) flags+	r <- peekCString res+	hexchat_free plugin res+	return r+	where flags = (if sc then 1 else 0) + (if sf then 2 else 0)++getInfo :: Plugin -> String -> IO (Maybe String)+getInfo plugin key+	| key `elem` ["gtkwin_ptr", "win_ptr"] = return Nothing+	| otherwise = withCString key $ \key -> do+		ptr <- hexchat_get_info plugin key+		if ptr == nullPtr then return Nothing+			else Just <$> peekCString ptr++getPrefs :: Plugin -> String -> (String -> IO a) -> (Int -> IO a) -> (Bool -> IO a) -> IO (Maybe a)+getPrefs plugin key cstr cint cbool = withCString key $ \key -> alloca $ \ps -> alloca $ \pi -> do+	ret <- hexchat_get_prefs plugin key ps pi+	case ret of+		0 -> return Nothing+		1 -> Just <$> (peek ps >>= peekCString >>= cstr)+		2 -> Just <$> (peek pi >>= cint . fromIntegral)+		3 -> Just <$> (peek pi >>= cbool . (== 0))++listGet :: Plugin -> String -> IO (Maybe List)+listGet plugin key = withCString key $ \key -> do+	ptr <- hexchat_list_get plugin key+	if coerce ptr == nullPtr then return Nothing+		else do+			u <- newIORef False+			Just <$> List u <$> newForeignPtrEnv (coerce ptr_finalize_list) (coerce plugin) ptr++listFields :: Plugin -> String -> IO [String]+listFields plugin key = withCString key $ \key -> do+	ret <- hexchat_list_fields plugin key+	if ret == nullPtr then return []+		else walkList ret 0+	where walkList ptr n = do+		str <- peekElemOff ptr n+		if str == nullPtr then return []+			else (:) <$> peekCString str <*> walkList ptr (n + 1)++listNext :: Plugin -> List -> IO Bool+listNext plugin (List u ptr) = do+	ret <- withForeignPtr ptr $ hexchat_list_next plugin+	writeIORef u ret+	return ret++listStr :: Plugin -> List -> String -> IO String+listStr _ _ "context" = error "Cannot listStr context"+listStr plugin (List u ptr) key = do+	b <- readIORef u+	unless b $ error "Attempted to use uninitialized List"+	withCString key $ \key -> withForeignPtr ptr $ \ptr -> do+		str <- hexchat_list_str plugin ptr key+		if str == nullPtr then putStrLn "null" >> return ""+			else peekCString str++listInt :: Plugin -> List -> String -> IO Int+listInt plugin (List u ptr) key = do+	b <- readIORef u+	unless b $ error "Attempted to use uninitialized List"+	withCString key $ \key -> withForeignPtr ptr $ \ptr -> do+		fromIntegral <$> hexchat_list_int plugin ptr key++listTime :: Plugin -> List -> String -> IO CTime+listTime plugin (List u ptr) key = do+	b <- readIORef u+	unless b $ error "Attempted to use uninitialized List"+	withCString key $ \key -> withForeignPtr ptr $ \ptr -> do+		hexchat_list_time plugin ptr key++hookCommand :: Plugin -> String -> CInt -> String -> ([String] -> [String] -> IO Eat) -> IO Hook+hookCommand plugin cmd pri desc f = do+	sf <- newStablePtr f+	hook <- with2CString cmd desc $ \cmd desc -> hexchat_hook_command plugin cmd pri ptr_call_haskell_command desc sf+	return hook++hookPrint :: Plugin -> String -> CInt -> ([String] -> IO Eat) -> IO Hook+hookPrint plugin cmd pri f = do+	sf <- newStablePtr f+	hook <- withCString cmd $ \cmd -> hexchat_hook_print plugin cmd pri ptr_call_haskell_print sf+	return hook++hookPrintAttrs :: Plugin -> String -> CInt -> ([String] -> EventAttrs -> IO Eat) -> IO Hook+hookPrintAttrs plugin cmd pri f = do+	sf <- newStablePtr f+	hook <- withCString cmd $ \cmd -> hexchat_hook_print_attrs plugin cmd pri ptr_call_haskell_print_attrs sf+	return hook++hookServer :: Plugin -> String -> CInt -> ([String] -> [String] -> IO Eat) -> IO Hook+hookServer plugin cmd pri f = do+	sf <- newStablePtr f+	hook <- withCString cmd $ \cmd -> hexchat_hook_server plugin cmd pri ptr_call_haskell_server sf+	return hook++hookServerAttrs :: Plugin -> String -> CInt -> ([String] -> [String] -> EventAttrs -> IO Eat) -> IO Hook+hookServerAttrs plugin cmd pri f = do+	sf <- newStablePtr f+	hook <- withCString cmd $ \cmd -> hexchat_hook_server_attrs plugin cmd pri ptr_call_haskell_server_attrs sf+	return hook++unhook :: Plugin -> Hook -> IO ()+unhook plugin hook = do+	sf <- hexchat_unhook plugin hook+	freeStablePtr sf++findContext :: Plugin -> Maybe String -> Maybe String -> IO (Maybe Context)+findContext plugin server channel = do+	ptr <- case (server, channel) of+		(Just server, Just channel) -> with2CString server channel $ \server channel -> hexchat_find_context plugin server channel+		(Nothing, Just channel) -> withCString channel $ \channel -> hexchat_find_context plugin nullPtr channel+		(Just server, Nothing) -> withCString server $ \server -> hexchat_find_context plugin server nullPtr+	if coerce ptr == nullPtr then return Nothing+		else return (Just ptr)++getContext :: Plugin -> IO Context+getContext plugin = hexchat_get_context plugin++setContext :: Plugin -> Context -> IO Bool+setContext plugin context = hexchat_set_context plugin context++pluginguiAdd :: Plugin -> String -> String -> String -> String -> IO Plugin+pluginguiAdd plugin file name desc ver = with4CString file name desc ver $ \file name desc ver -> hexchat_plugingui_add plugin file name desc ver nullPtr++pluginguiRemove :: Plugin -> Plugin -> IO ()+pluginguiRemove = hexchat_plugingui_remove++type Plugin_Init = Plugin -> Ptr CString -> Ptr CString -> Ptr CString -> CString -> IO CInt+type Plugin_Deinit = Plugin -> IO CInt+++data StaticData = StaticData+	{+		s_plugin :: IORef Plugin,+		s_handle :: IORef (IORef Plugin),+		s_hooks :: IORef (IORef [(Plugin, Hook)])+	}++lPlugin = s_plugin staticData+lHandle = s_handle staticData+lHooks = s_hooks staticData++{-# NOINLINE staticData #-}+staticData = unsafePerformIO $ StaticData+	<$> (newIORef $ error "unlinked plugin in StaticData")+	<*> (newIORef $ error "unlinked handle in StaticData")+	<*> (newIORef $ error "unlinked hooks in StaticData")++getPlugin :: IO Plugin+getPlugin = readIORef lPlugin++getHandle :: IO Plugin+getHandle = readIORef lHandle >>= readIORef++withHandle :: Plugin -> IO a -> IO a+withHandle handle f = bracket (swap handle) swap (const f)+	where swap handle = do+		loc <- readIORef lHandle+		atomicModifyIORef loc (\old -> (handle, old))++initStaticData :: Plugin -> IO ()+initStaticData plugin = do+	writeIORef lPlugin plugin+	writeIORef lHandle =<< newIORef plugin+	writeIORef lHooks =<< newIORef []++joinStaticData :: StaticData -> IO ()+joinStaticData s = do+	readIORef lPlugin >>= writeIORef (s_plugin s)+	readIORef lHandle >>= writeIORef (s_handle s)+	readIORef lHooks >>= writeIORef (s_hooks s)++unhookHandle :: Plugin -> IO ()+unhookHandle handle = do+	m <- readIORef lHooks >>= readIORef+	plugin <- getPlugin+	traverse (unhook plugin) $ map snd $ filter ((== handle) . fst) m+	readIORef lHooks >>= flip modifyIORef (filter ((/= handle) . fst))
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 mniip++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hexchat.cabal view
@@ -0,0 +1,39 @@+name:                hexchat+version:             0.0.1.0+synopsis:            Haskell scripting interface for HexChat+description:+ This package builds a shared object ready for loading into HexChat, that will compile and interpret scripts written in Haskell; and also a Haskell library that said scripts should import and use to interface with HexChat.+ .+ At the moment the scripting interface is not finalized and may (and will) change in a future.+ .+ At the moment only Linux is supported.+ .+ For instructions on how to write a script, see the 'HexChat' module.+ .+ Currently the plugin only understands the classic @/load@, @/unload@, @/reload@ commands.+ .+ To automatically load the plugin symlink or copy @~\/.cabal\/lib\/libhexchat-haskell.so@ (or @\/usr\/local\/lib\/libhexchat-haskell.so@) to @~\/.config\/hexchat\/addons\/@ (or @\/usr\/lib\/hexchat\/plugins\/@).+license:             MIT+license-file:        LICENSE+author:              mniip+maintainer:          mniip@mniip.com+copyright:           (C) 2017 mniip+homepage:            https://github.com/mniip/hexchat-haskell+category:            System+build-type:          Simple+cabal-version:       >=2.0++library+  exposed-modules:     HexChat, HexChat.Internal+  other-extensions:    CApiFFI+  build-depends:       base >=4.10 && <4.11, containers >=0.5 && <0.6+  default-language:    Haskell2010++foreign-library hexchat-haskell+  type:                native-shared+  hs-source-dirs:      plugin+  c-sources:           plugin/plugin.c+  other-modules:       HexChat.Linker, Paths_hexchat+  other-extensions:    CApiFFI+  build-depends:       base >=4.10 && <4.11, deepseq >= 1.0 && < 1.5, ghc-prim >=0.5 && <0.6, ghc-paths >=0.1 && <0.2, ghc >= 8.0 && < 8.3, ghci >= 8.0 && < 8.3, hexchat == 0.0.0.0+  default-language:    Haskell2010
+ plugin/HexChat/Linker.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS_GHC -fno-warn-tabs #-}++module HexChat.Linker where++import Prelude hiding (print)++import Control.DeepSeq+import Control.Exception+import Data.Function+import Data.IORef+import Data.List+import Data.Maybe+import Data.Version+import Foreign+import Foreign.C.String+import GHC.Types+import System.IO.Unsafe+import Unsafe.Coerce++import GHC.Paths (libdir)++import ErrUtils+import Exception+import Config+import DynFlags+import GHC+import GHCi.RemoteTypes+import GhcMonad+import HscMain+import HscTypes+import Linker+import Name+import Outputable++import HexChat+import qualified HexChat.Internal as I+import Paths_hexchat++infoSymbol = "info"++data Script = Script+	{+		scriptFile :: String,+		scriptHandle :: I.Plugin,+		scriptInfo :: ModInfo Any,+		scriptNonce :: Any,+		scriptEnv :: HscEnv+	}++{-# NOINLINE scripts #-}+scripts :: IORef [Script]+scripts = unsafePerformIO $ newIORef []++reportException :: ExceptionMonad m => m a -> m a -> m a+reportException def f = gcatch f $ \e -> do+	liftIO $ print $ show (e :: SomeException)+	def++suppress :: ExceptionMonad m => Bool -> m a -> (a -> m b) -> m (Maybe b)+suppress True m f = gcatch (Just <$> m) (\e -> return Nothing `const` (e :: SomeException)) >>= traverse f+suppress False m f = Just <$> (m >>= f)++logAction :: LogAction+logAction dflags reason severity srcSpan style msg = print $ renderWithStyle dflags (mkLocMessageAnn Nothing severity srcSpan msg) style++loadScript :: Bool -> String -> Ghc Bool+loadScript sup file = reportException (return True) $ do+	dflags <- getSessionDynFlags+	liftIO (newHscEnv dflags) >>= setSession+	mv <- suppress sup (guessTarget file Nothing) $ \target -> do+		setTargets [target]+		load LoadAllTargets++		graph <- depanal [] True+		let mod = ms_mod $ fromMaybe (error "Module not loaded") $ find (\m -> ml_hs_file (ms_location m) == Just file) graph+		modinfo <- fromMaybe (error "Module not loaded") <$> getModuleInfo mod+		let name = fromMaybe (error $ "No symbol '" ++ infoSymbol ++ "'") $ find (\n -> getOccString n == infoSymbol) $ modInfoExports modinfo++		hsc <- getSession+		info <- liftIO $ do+			fref <- getHValue hsc name+			withForeignRef fref $ \ref -> do+				value <- localRef ref+				return (unsafeCoerce value :: ModInfo Any)+		return (info, hsc)+	case mv of+		Nothing -> return False+		Just (info, hsc) -> liftIO $ do+			evaluate $ force (modName info, modVersion info, modAuthor info, modDescription info)+			I.joinStaticData (modStaticData info)+			plugin <- I.getPlugin+			handle <- I.pluginguiAdd plugin file (modName info) (modDescription info) (modVersion info)+			nonce <- reportException (return undefined) $ I.withHandle handle $ modInit info+			modifyIORef scripts $ (Script file handle info nonce hsc :)+			return True++unloadScript :: Bool -> String -> Ghc Bool+unloadScript sup file = reportException (return True) $ do+	mf <- liftIO $ find (\s -> scriptFile s == file) <$> readIORef scripts+	case mf of+		Nothing -> if sup then return False else liftIO $ evaluate $ error "No such script"+		Just s -> do+			liftIO $ modifyIORef scripts (deleteBy ((==) `on` scriptHandle) s)+			liftIO $ I.withHandle (scriptHandle s) $ deinitScript s+			return True++deinitScript :: Script -> IO ()+deinitScript s = do+	plugin <- I.getPlugin+	I.pluginguiRemove plugin $ scriptHandle s+	finally (modDeinit (scriptInfo s) (scriptNonce s)) $ I.unhookHandle $ scriptHandle s++commandLoad, commandUnload, commandReload :: [String] -> [String] -> Ghc Eat+commandLoad w we = do+	let (_:file:_) = w+	b <- loadScript True file+	return (if b then EatAll else EatNone)++commandUnload w we = do+	let (_:file:_) = w+	b <- unloadScript True file+	return (if b then EatAll else EatNone)++commandReload w we = do+	let (_:file:_) = w+	b <- unloadScript True file+	if not b then return EatNone+		else do+			loadScript False file+			return EatAll++foreign export ccall plugin_init :: I.Plugin_Init+foreign export ccall plugin_deinit :: I.Plugin_Deinit++{-# NOINLINE borrowedStrings #-}+borrowedStrings :: IORef [CString]+borrowedStrings = unsafePerformIO $ newIORef []++{-# NOINLINE session #-}+session :: IORef Session+session = unsafePerformIO $ newIORef (error "uninitialized Session")++plugin_init plugin pname pdesc pver arg = reportException (return 0) $ do+	I.initStaticData plugin++	name <- newCString "Haskell"+	desc <- newCString "Haskell scripting plugin"+	ver <- newCString $ showVersion version ++ "/" ++ cProjectVersion+	modifyIORef borrowedStrings ([name, desc, ver] ++)++	poke pname name+	poke pdesc desc+	poke pver ver++	runGhc (Just libdir) $ do+		dflags <- getSessionDynFlags+		(dflags', _, _) <- parseDynamicFlagsCmdLine dflags [noLoc "-package ghc"]+		setSessionDynFlags $ updateWays $ addWay' WayDyn $ dflags' { ghcLink = LinkInMemory, log_action = logAction }+		reifyGhc $ \s -> do+			writeIORef session s+			hookCommand "load" pri_NORM "" $ \w we -> reflectGhc (commandLoad w we) s+			hookCommand "unload" pri_NORM "" $ \w we -> reflectGhc (commandUnload w we) s+			hookCommand "reload" pri_NORM "" $ \w we -> reflectGhc (commandReload w we) s++		return 1++plugin_deinit plugin = reportException (return 0) $ do+	s <- readIORef session+	flip reflectGhc s $ do+		liftIO $ traverse deinitScript =<< readIORef scripts+		liftIO $ readIORef borrowedStrings >>= mapM free+		liftIO $ writeIORef borrowedStrings []+		return 1
+ plugin/plugin.c view
@@ -0,0 +1,31 @@+#define _GNU_SOURCE+#include <stdio.h>+#include <hexchat-plugin.h>++#include "HsFFI.h"++#include "HexChat/Linker_stub.h"++extern void __stginit_HexChatziLinker(void);++int hexchat_plugin_init(hexchat_plugin *plugin, char **name, char **desc, char **ver, char *arg)+{+	int argc = 0;+	char *argva[] = {NULL};+	char **argv = argva;+	hs_init(&argc, &argv);+	hs_add_root(__stginit_HexChatziLinker);++	int result = plugin_init(plugin, name, desc, ver, arg);+	if(!result)+		hs_exit();+	return result;+}++int hexchat_plugin_deinit(hexchat_plugin *plugin)+{+	int result = plugin_deinit(plugin);+	if(result)+		hs_exit();+	return result;+}