module Graphics.Text.Font.Choose.Config where

import Graphics.Text.Font.Choose.Strings
import Graphics.Text.Font.Choose.FontSet
import Graphics.Text.Font.Choose.CharSet
import Graphics.Text.Font.Choose.Pattern
import Graphics.Text.Font.Choose.ObjectSet

import Foreign.ForeignPtr
import Foreign.Ptr (Ptr, nullPtr, FunPtr)
import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
import Foreign.Storable (Storable(..))
import Foreign.C.String (CString, peekCString, withCString)
import System.IO.Unsafe (unsafePerformIO)

import Control.Exception (bracket)
import Graphics.Text.Font.Choose.Result (throwNull, throwFalse, throwPtr)

type Config = ForeignPtr Config'
data Config'
type Config_ = Ptr Config'

configCreate :: IO Config
configCreate = newForeignPtr fcConfigDestroy =<< throwNull <$> fcConfigCreate
foreign import ccall "FcConfigCreate" fcConfigCreate :: IO Config_
foreign import ccall "&FcConfigDestroy" fcConfigDestroy :: FunPtr (Config_ -> IO ())

configSetCurrent :: Config -> IO ()
configSetCurrent config = throwFalse =<< (withForeignPtr config $ fcConfigSetCurrent)
foreign import ccall "FcConfigSetCurrent" fcConfigSetCurrent :: Config_ -> IO Bool

configGetCurrent :: IO Config
configGetCurrent = (throwNull <$> fcConfigReference nullPtr) >>=
    newForeignPtr fcConfigDestroy
foreign import ccall "FcConfigReference" fcConfigReference :: Config_ -> IO Config_

configUptoDate :: Config -> IO Bool
configUptoDate config = withForeignPtr config $ fcConfigUptoDate
foreign import ccall "FcConfigUptoDate" fcConfigUptoDate :: Config_ -> IO Bool

configHome :: IO (Maybe String)
configHome = do
    ret <- fcConfigHome
    if ret == nullPtr then return Nothing else Just <$> peekCString ret
foreign import ccall "FcConfigHome" fcConfigHome :: IO CString

foreign import ccall "FcConfigEnableHome" configEnableHome :: Bool -> IO Bool

configBuildFonts :: Config -> IO ()
configBuildFonts config = throwFalse =<< (withForeignPtr config $ fcConfigBuildFonts)
configBuildFonts' :: IO ()
configBuildFonts' = throwFalse =<< fcConfigBuildFonts nullPtr
foreign import ccall "FcConfigBuildFonts" fcConfigBuildFonts :: Config_ -> IO Bool

configGetConfigDirs :: Config -> IO StrList
configGetConfigDirs = configStrsFunc fcConfigGetConfigDirs
configGetConfigDirs' :: IO StrList
configGetConfigDirs' = thawStrList =<< fcConfigGetConfigDirs nullPtr
foreign import ccall "FcConfigGetConfigDirs" fcConfigGetConfigDirs :: Config_ -> IO StrList_

configGetFontDirs :: Config -> IO StrList
configGetFontDirs = configStrsFunc fcConfigGetFontDirs
configGetFontDirs' :: IO StrList
configGetFontDirs' = thawStrList_ $ fcConfigGetFontDirs nullPtr
foreign import ccall "FcConfigGetFontDirs" fcConfigGetFontDirs :: Config_ -> IO StrList_

configGetConfigFiles :: Config -> IO StrList
configGetConfigFiles = configStrsFunc fcConfigGetConfigFiles
configGetConfigFiles' :: IO StrList
configGetConfigFiles' = thawStrList_ $ fcConfigGetConfigFiles nullPtr
foreign import ccall "FcConfigGetConfigFiles" fcConfigGetConfigFiles :: Config_ -> IO StrList_

configGetCacheDirs :: Config -> IO StrList
configGetCacheDirs = configStrsFunc fcConfigGetCacheDirs
configGetCacheDirs' :: IO StrList
configGetCacheDirs' = thawStrList_ $ fcConfigGetCacheDirs nullPtr
foreign import ccall "FcConfigGetCacheDirs" fcConfigGetCacheDirs :: Config_ -> IO StrList_

data SetName = SetSystem | SetApplication deriving (Enum, Eq, Show, Read)
configGetFonts :: Config -> SetName -> IO FontSet
configGetFonts config set = do
    ret <- withForeignPtr config $ flip fcConfigGetFonts $ fromEnum set
    thawFontSet $ throwNull ret
configGetFonts' :: SetName -> IO FontSet
configGetFonts' set = do
    ret <- fcConfigGetFonts nullPtr $ fromEnum set
    thawFontSet $ throwNull ret
foreign import ccall "FcConfigGetFonts" fcConfigGetFonts :: Config_ -> Int -> IO FontSet_

configGetRescanInterval :: Config -> IO Int
configGetRescanInterval = flip withForeignPtr $ fcConfigGetRescanInterval
configGetRescanInterval' :: IO Int
configGetRescanInterval' = fcConfigGetRescanInterval nullPtr
foreign import ccall "FcConfigGetRescanInterval" fcConfigGetRescanInterval ::
    Config_ -> IO Int

configSetRescanInterval :: Config -> Int -> IO ()
configSetRescanInterval config val =
    throwFalse =<< (withForeignPtr config $ flip fcConfigSetRescanInterval val)
configSetRescanInterval' :: Int -> IO ()
configSetRescanInterval' v = throwFalse =<< fcConfigSetRescanInterval nullPtr v
foreign import ccall "FcConfigSetRescanInterval" fcConfigSetRescanInterval ::
    Config_ -> Int -> IO Bool

configAppFontAddFile :: Config -> String -> IO ()
configAppFontAddFile config file = throwFalse =<<
    (withForeignPtr config $ \config' -> withCString file $ \file' ->
        fcConfigAppFontAddFile config' file')
configAppFontAddFile' :: String -> IO ()
configAppFontAddFile' file =
    throwFalse =<< (withCString file $ fcConfigAppFontAddFile nullPtr)
foreign import ccall "FcConfigAppFontAddFile" fcConfigAppFontAddFile ::
    Config_ -> CString -> IO Bool

configAppFontAddDir :: Config -> String -> IO ()
configAppFontAddDir config file = throwFalse =<<
    (withForeignPtr config $ \config' -> withCString file $ fcConfigAppFontAddDir config')
configAppFontAddDir' :: String -> IO ()
configAppFontAddDir' v = throwFalse =<< (withCString v $ fcConfigAppFontAddDir nullPtr)
foreign import ccall "FcConfigAppFontAddDir" fcConfigAppFontAddDir ::
    Config_ -> CString -> IO Bool

configAppFontClear :: Config -> IO ()
configAppFontClear config = throwFalse =<< withForeignPtr config fcConfigAppFontClear
configAppFontClear' :: IO ()
configAppFontClear' = throwFalse =<< fcConfigAppFontClear nullPtr
foreign import ccall "FcConfigAppFontClear" fcConfigAppFontClear :: Config_ -> IO Bool

data MatchKind = MatchPattern | MatchFont | MatchScan deriving Enum
configSubstituteWithPat :: Config -> Pattern -> Pattern -> MatchKind -> Pattern
configSubstituteWithPat config p p_pat kind = unsafePerformIO $
    withForeignPtr config $ \config' -> withPattern p $ \p' ->
        withPattern p_pat $ \p_pat' -> do
            ok <- fcConfigSubstituteWithPat config' p' p_pat' $ fromEnum kind
            throwFalse ok
            thawPattern p'
configSubstituteWithPat' :: Pattern -> Pattern -> MatchKind -> Pattern
configSubstituteWithPat' p p_pat kind = unsafePerformIO $
    withPattern p $ \p' -> withPattern p_pat $ \p_pat' -> do
        ok <- fcConfigSubstituteWithPat nullPtr p' p_pat' $ fromEnum kind
        throwFalse ok
        thawPattern p'
foreign import ccall "FcConfigSubstituteWithPat" fcConfigSubstituteWithPat ::
    Config_ -> Pattern_ -> Pattern_ -> Int -> IO Bool

configSubstitute :: Config -> Pattern -> MatchKind -> Pattern
configSubstitute config p kind = unsafePerformIO $
    withForeignPtr config $ \config' -> withPattern p $ \p' -> do
        ok <- fcConfigSubstitute config' p' $ fromEnum kind
        throwFalse ok
        thawPattern p'
configSubstitute' :: Pattern -> MatchKind -> Pattern
configSubstitute' p kind = unsafePerformIO $ withPattern p $ \p' -> do
    ok <- fcConfigSubstitute nullPtr p' $ fromEnum kind
    throwFalse ok
    thawPattern p'
foreign import ccall "FcConfigSubstitute" fcConfigSubstitute ::
    Config_ -> Pattern_ -> Int -> IO Bool

fontMatch :: Config -> Pattern -> Maybe Pattern
fontMatch config pattern = unsafePerformIO $ withForeignPtr config $ \config' ->
    withPattern pattern $ \pattern' -> alloca $ \res' -> do
        ret <- fcFontMatch config' pattern' res'
        throwPtr res' $ thawPattern_ $ pure ret
fontMatch' :: Pattern -> Maybe Pattern
fontMatch' pattern = unsafePerformIO $ withPattern pattern $ \pattern' -> alloca $ \res' -> do
    ret <- fcFontMatch nullPtr pattern' res'
    throwPtr res' $ thawPattern_ $ pure ret
foreign import ccall "FcFontMatch" fcFontMatch ::
    Config_ -> Pattern_ -> Ptr Int -> IO Pattern_

fontSort :: Config -> Pattern -> Bool -> CharSet -> Maybe FontSet
fontSort config pattern trim csp = unsafePerformIO $ withForeignPtr config $ \config' ->
    withPattern pattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do
        ret <- fcFontSort config' pattern' trim csp' res'
        throwPtr res' $ thawFontSet_ $ pure ret
fontSort' :: Pattern -> Bool -> CharSet -> Maybe FontSet
fontSort' pattern trim csp = unsafePerformIO $ withPattern pattern $ \pattern' ->
    withCharSet csp $ \csp' -> alloca $ \res' -> do
        ret <- fcFontSort nullPtr pattern' trim csp' res'
        throwPtr res' $ thawFontSet_ $ pure ret
foreign import ccall "FcFontSort" fcFontSort ::
    Config_ -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_

fontRenderPrepare :: Config -> Pattern -> Pattern -> Pattern
fontRenderPrepare config pat font = unsafePerformIO $ withForeignPtr config $ \config' ->
    withPattern pat $ \pat' -> withPattern font $ \font' -> do
        ret <- fcFontRenderPrepare config' pat' font'
        thawPattern_ $ pure $ throwNull ret
fontRenderPrepare' :: Pattern -> Pattern -> Pattern
fontRenderPrepare' pat font = unsafePerformIO $ withPattern pat $ \pat' ->
    withPattern font $ \font' -> do
        ret <- fcFontRenderPrepare nullPtr pat' font'
        thawPattern_ $ pure ret
foreign import ccall "FcFontRenderPrepare" fcFontRenderPrepare ::
    Config_ -> Pattern_ -> Pattern_ -> IO Pattern_

fontList :: Config -> Pattern -> ObjectSet -> FontSet
fontList config p os = unsafePerformIO $ withForeignPtr config $ \config' ->
    withPattern p $ \p' -> withObjectSet os $ \os' -> do
        ret <- fcFontList config' p' os'
        thawFontSet_ $ pure ret
fontList' :: Pattern -> ObjectSet -> FontSet
fontList' p os = unsafePerformIO $ withPattern p $ \p' -> withObjectSet os $ \os' -> do
    ret <- fcFontList nullPtr p' os'
    thawFontSet_ $ pure ret
foreign import ccall "FcFontList" fcFontList ::
    Config_ -> Pattern_ -> ObjectSet_ -> IO FontSet_

configGetFilename :: Config -> String -> String
configGetFilename config name = unsafePerformIO $ withForeignPtr config $ \config' ->
    withCString name $ \name' -> do
        ret <- fcConfigGetFilename config' name'
        peekCString' ret
configGetFilename' :: String -> String
configGetFilename' name = unsafePerformIO $ withCString name $ \name' -> do
    ret <- fcConfigGetFilename nullPtr name'
    peekCString' ret
foreign import ccall "FcConfigGetFilename" fcConfigGetFilename :: Config_ -> CString -> IO CString
peekCString' txt = bracket (pure $ throwNull txt) free peekCString

configParseAndLoad :: Config -> String -> Bool -> IO Bool
configParseAndLoad config name complain = withForeignPtr config $ \config' ->
    withCString name $ \name' -> fcConfigParseAndLoad config' name' complain
configParseAndLoad' :: String -> Bool -> IO Bool
configParseAndLoad' name complain =
    withCString name $ \name' -> fcConfigParseAndLoad nullPtr name' complain
foreign import ccall "FcConfigParseAndLoad" fcConfigParseAndLoad ::
    Config_ -> CString -> Bool -> IO Bool

configParseAndLoadFromMemory :: Config -> String -> Bool -> IO Bool
configParseAndLoadFromMemory config buffer complain = withForeignPtr config $ \config' ->
    withCString buffer $ \buffer' ->
        fcConfigParseAndLoadFromMemory config' buffer' complain
configParseAndLoadFromMemory' :: String -> Bool -> IO Bool
configParseAndLoadFromMemory' buffer complain = withCString buffer $ \buffer' ->
    fcConfigParseAndLoadFromMemory nullPtr buffer' complain
foreign import ccall "FcConfigParseAndLoadFromMemory" fcConfigParseAndLoadFromMemory ::
    Config_ -> CString -> Bool -> IO Bool

configGetSysRoot :: Config -> IO String
configGetSysRoot = flip withForeignPtr $ \config' -> do
    ret <- fcConfigGetSysRoot config'
    peekCString $ throwNull ret
configGetSysRoot' :: IO String
configGetSysRoot' = (peekCString .throwNull) =<< fcConfigGetSysRoot nullPtr
foreign import ccall "FcConfigGetSysRoot" fcConfigGetSysRoot :: Config_ -> IO CString

configSetSysRoot :: Config -> String -> IO ()
configSetSysRoot config val = withForeignPtr config $ \config' -> withCString val $
    fcConfigSetSysRoot config'
configSetSysRoot' :: String -> IO ()
configSetSysRoot' val = withCString val $ fcConfigSetSysRoot nullPtr
foreign import ccall "FcConfigSetSysRoot" fcConfigSetSysRoot :: Config_ -> CString -> IO ()

configGetFileInfo :: Config -> IO [(FilePath, String, Bool)]
configGetFileInfo config =
  withForeignPtr config $ \config' -> allocaBytes configFileInfoIter'Size $ \iter' -> do
    fcConfigFileInfoIterInit config' iter'
    let readEnt = alloca $ \name' -> alloca $ \description' -> alloca $ \enabled' -> do {
        ok <- fcConfigFileInfoIterGet config' iter' name' description' enabled';
        if ok then do
            name <- peekCString =<< peek name'
            description <- peekCString =<< peek description'
            enabled <- peek enabled'
            return $ Just (name, description, enabled)
        else return Nothing}
    let go = do {
        ent' <- readEnt;
        case ent' of
            Just ent -> do
                ok <- fcConfigFileInfoIterNext config' iter'
                ents <- if ok then go else return []
                return (ent : ents)
            Nothing -> return []}
    go
data ConfigFileInfoIter'
foreign import ccall "size_ConfigFileInfoIter" configFileInfoIter'Size :: Int
type ConfigFileInfoIter_ = Ptr ConfigFileInfoIter'
foreign import ccall "FcConfigFileInfoIterInit" fcConfigFileInfoIterInit ::
    Config_ -> ConfigFileInfoIter_ -> IO ()
foreign import ccall "FcConfigFileInfoIterNext" fcConfigFileInfoIterNext ::
    Config_ -> ConfigFileInfoIter_ -> IO Bool
foreign import ccall "FcConfigFileInfoIterGet" fcConfigFileInfoIterGet ::
    Config_ -> ConfigFileInfoIter_ -> Ptr CString -> Ptr CString -> Ptr Bool -> IO Bool

------

configStrsFunc :: (Config_ -> IO StrList_) -> Config -> IO StrList
configStrsFunc cb config = thawStrList_ $ withForeignPtr config cb