Haskell sources moved to src/ to unclutter toplevel

1 files changed, 0 insertions, 259 deletions

diff --git a/XUtil.hsc b/XUtil.hsc
deleted file mode 100644
index d5bb591..0000000
--- a/XUtil.hsc
+++ /dev/null
@@ -1,259 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module      :  XUtil
--- Copyright   :  (C) 2007 Andrea Rossato
--- License     :  BSD3
---
--- Maintainer  :  andrea.rossato@unitn.it
--- Stability   :  unstable
--- Portability :  unportable
---
------------------------------------------------------------------------------
-
-module XUtil
-    ( XFont
-    , initFont
-    , initCoreFont
-    , initUtf8Font
-    , textExtents
-    , textWidth
-    , printString
-    , initColor
-    , newWindow
-    , nextEvent'
-    , readFileSafe
-    , hGetLineSafe
-    , io
-    , fi
-    , withColors
-    , DynPixel(..)
-    ) where
-
-import Control.Concurrent
-import Control.Monad.Trans
-import Data.IORef
-import Foreign
-import Graphics.X11.Xlib hiding (textExtents, textWidth)
-import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
-import Graphics.X11.Xlib.Extras
-import System.Mem.Weak ( addFinalizer )
-import System.Posix.Types (Fd(..))
-import System.IO
-#if defined XFT || defined UTF8
-# if __GLASGOW_HASKELL__ < 612
-import Foreign.C
-import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
-# else
-import qualified System.IO as UTF8 (readFile,hGetLine)
-# endif
-#endif
-#if defined XFT
-import Data.List
-import Graphics.X11.Xft
-import Graphics.X11.Xrender
-#endif
-
-readFileSafe :: FilePath -> IO String
-#if defined XFT || defined UTF8
-readFileSafe = UTF8.readFile
-#else
-readFileSafe = readFile
-#endif
-
-hGetLineSafe :: Handle -> IO String
-#if defined XFT || defined UTF8
-hGetLineSafe = UTF8.hGetLine
-#else
-hGetLineSafe = hGetLine
-#endif
-
--- Hide the Core Font/Xft switching here
-data XFont = Core FontStruct
-           | Utf8 FontSet
-#ifdef XFT
-           | Xft  XftFont
-#endif
-
--- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend
--- Example: 'xft:Sans-10'
-initFont :: Display ->String -> IO XFont
-initFont d s =
-#ifdef XFT
-       let xftPrefix = "xft:" in
-       if  xftPrefix `isPrefixOf` s then
-           fmap Xft $ initXftFont d s
-       else
-#endif
-#if defined UTF8 ||  __GLASGOW_HASKELL__ >= 612
-           fmap Utf8 $ initUtf8Font d s
-#else
-           fmap Core $ initCoreFont d s
-#endif
-
--- | Given a fontname returns the font structure. If the font name is
---  not valid the default font will be loaded and returned.
-initCoreFont :: Display -> String -> IO FontStruct
-initCoreFont d s = do
-  f <- catch getIt fallBack
-  addFinalizer f (freeFont d f)
-  return f
-      where getIt    = loadQueryFont d s
-            fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-
--- | Given a fontname returns the font structure. If the font name is
---  not valid the default font will be loaded and returned.
-initUtf8Font :: Display -> String -> IO FontSet
-initUtf8Font d s = do
-  setupLocale
-  (_,_,f) <- catch getIt fallBack
-  addFinalizer f (freeFontSet d f)
-  return f
-      where getIt    = createFontSet d s
-            fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-
-#ifdef XFT
-initXftFont :: Display -> String -> IO XftFont
-initXftFont d s = do
-  setupLocale
-  f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s)
-  addFinalizer f (xftFontClose d f)
-  return f
-#endif
-
-textWidth :: Display -> XFont -> String -> IO Int
-textWidth _   (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
-textWidth _   (Core fs) s = return $ fi $ Xlib.textWidth fs s
-#ifdef XFT
-textWidth dpy (Xft xftdraw) s = do
-    gi <- xftTextExtents dpy xftdraw s
-    return $ xglyphinfo_xOff gi
-#endif
-
-textExtents :: XFont -> String -> IO (Int32,Int32)
-textExtents (Core fs) s = do
-  let (_,a,d,_) = Xlib.textExtents fs s
-  return (a,d)
-textExtents (Utf8 fs) s = do
-  let (_,rl)  = wcTextExtents fs s
-      ascent  = fi $ - (rect_y rl)
-      descent = fi $ rect_height rl + (fi $ rect_y rl)
-  return (ascent, descent)
-#ifdef XFT
-textExtents (Xft xftfont) _ = do
-  ascent  <- fi `fmap` xftfont_ascent  xftfont
-  descent <- fi `fmap` xftfont_descent xftfont
-  return (ascent, descent)
-#endif
-
-printString :: Display -> Drawable -> XFont -> GC -> String -> String
-            -> Position -> Position -> String  -> IO ()
-printString d p (Core fs) gc fc bc x y s = do
-    setFont d gc $ fontFromFontStruct fs
-    withColors d [fc, bc] $ \[fc', bc'] -> do
-      setForeground d gc fc'
-      setBackground d gc bc'
-      drawImageString d p gc x y s
-
-printString d p (Utf8 fs) gc fc bc x y s =
-    withColors d [fc, bc] $ \[fc', bc'] -> do
-      setForeground d gc fc'
-      setBackground d gc bc'
-      io $ wcDrawImageString d p fs gc x y s
-
-#ifdef XFT
-printString dpy drw fs@(Xft font) gc fc bc x y s = do
-  let screen   = defaultScreenOfDisplay dpy
-      colormap = defaultColormapOfScreen screen
-      visual   = defaultVisualOfScreen screen
-  withColors dpy [bc] $ \[bcolor] -> do
-    (a,d)  <- textExtents fs s
-    gi     <- xftTextExtents dpy font s
-    setForeground dpy gc bcolor
-    fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
-                             (y - fi (a + d))
-                             (fi $ xglyphinfo_xOff gi)
-                             (fi $ 4 + a + d)
-    withXftDraw dpy drw visual colormap $
-      \draw -> withXftColorName dpy visual colormap fc $
-      \color -> xftDrawString draw color font x (y - 2) s
-#endif
-
-data DynPixel = DynPixel { allocated :: Bool
-                         , pixel     :: Pixel
-                         }
-
--- | Get the Pixel value for a named color: if an invalid name is
--- given the black pixel will be returned.
-initColor :: Display -> String -> IO DynPixel
-initColor dpy c = (initColor' dpy c) `catch`
-                  (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy))
-
-type ColorCache = [(String, Color)]
-{-# NOINLINE colorCache #-}
-colorCache :: IORef ColorCache
-colorCache = unsafePerformIO $ newIORef []
-
-getCachedColor :: String -> IO (Maybe Color)
-getCachedColor color_name = lookup color_name `fmap` readIORef colorCache
-
-putCachedColor :: String -> Color -> IO ()
-putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c
-
-initColor' :: Display -> String -> IO DynPixel
-initColor' dpy c = do
-  let colormap = defaultColormap dpy (defaultScreen dpy)
-  cached_color <- getCachedColor c
-  c' <- case cached_color of
-          Just col -> return col
-          _        -> do (c'', _) <- allocNamedColor dpy colormap c
-                         putCachedColor c c''
-                         return c''
-  return $ DynPixel True (color_pixel c')
-
-withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
-withColors d cs f = do
-  ps <- mapM (io . initColor d) cs
-  f $ map pixel ps
-
--- | Creates a window with the attribute override_redirect set to True.
--- Windows Managers should not touch this kind of windows.
-newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window
-newWindow dpy scr rw (Rectangle x y w h) o = do
-  let visual   = defaultVisualOfScreen scr
-      attrmask = cWOverrideRedirect
-  allocaSetWindowAttributes $
-         \attributes -> do
-           set_override_redirect attributes o
-           createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
-                        inputOutput visual attrmask attributes
--- | A version of nextEvent that does not block in foreign calls.
-nextEvent' :: Display -> XEventPtr -> IO ()
-nextEvent' d p = do
-    pend <- pending d
-    if pend /= 0
-        then nextEvent d p
-        else do
-            threadWaitRead (Fd fd)
-            nextEvent' d p
- where
-    fd = connectionNumber d
-
-io :: MonadIO m => IO a -> m a
-io = liftIO
-
--- | Short-hand for 'fromIntegral'
-fi :: (Integral a, Num b) => a -> b
-fi = fromIntegral
-
-#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8)
-#include <locale.h>
-foreign import ccall unsafe "locale.h setlocale"
-    setlocale :: CInt -> CString -> IO CString
-
-setupLocale :: IO ()
-setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return ()
-# else
-setupLocale :: IO ()
-setupLocale = return ()
-#endif