{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Stopgap.System.GLib.Error where

import Control.Exception
import Control.Exception.Hierarchy
import Foreign.Ptr
import Foreign.C.String
import Foreign.C.Struct
import Foreign.Storable
import Data.Word
import Data.Int

#include <gtk/gtk.h>

type PGChar = Ptr #{type gchar}

struct "E_" #{size GError} #{alignment GError} [
	("domain_", ''#{type GQuark},
		[| #{peek GError, domain} |], [| #{poke GError, domain} |]),
	("code_", ''#{type gint},
		[| #{peek GError, code} |], [| #{poke GError, code} |]),
	("message_", ''PGChar,
		[| #{peek GError, message} |], [| #{poke GError, message} |])
	]
	[''Show, ''Storable]

type DomainCode = (#{type GQuark}, #{type gint})

data EOthers = EOthers {
	domainCode :: DomainCode,
	message :: String }

instance Show EOthers where
	show (EOthers (d, c) msg) = "Error: " ++ show d ++ " " ++ show c ++ " " ++ msg

exceptionHierarchy Nothing $ ExNode "E" [
	ExType ''EOthers ]

type MakeEFun = DomainCode -> String -> IO (Maybe E)

fromC :: (?makeEFuns :: [MakeEFun]) =>  E_ -> IO E
fromC E_ { e_Domain_ = d, e_Code_ = c, e_Message_ = cm } = do
	get ?makeEFuns =<< peekCString (castPtr cm)
	where
	get = \case
		[] -> pure . E . EOthers (d, c)
		f : fs -> \msg -> maybe (get fs msg) pure =<< f (d, c) msg

free :: Ptr E_ -> IO ()
free = c_g_error_free

foreign import ccall "g_error_free" c_g_error_free :: Ptr E_ -> IO ()