polymorphic approach

for further refactoring.

.gitignore

@@ -0,0 +1,12 @@
+# .gitignore
+
+
+*~
+*#
+.#*
+*rej
+*orig
+pinentry*
+*.hi
+*.o
+*.a

README.md

@@ -5,26 +5,9 @@ wazajisho library for handling japanese text in haskell
 <img src="https://git.ajattix.org/hashirama/waza-hs/raw/branch/main/misc/cover.jpg" alt="cover" width="30%" height="30%">
 
 
-### FileUtils.h
 
-for managing dictionaries we have a custom data structure, and you can use it that way:
-
-```haskell
--- Access all directories in the list of FileGroups
-let directories = map directory fileGroups
-print directories -- ["/mnt/data1", "/mnt/data2"]
-
--- Access all file lists in the list of FileGroups
-let filesList = map files fileGroups
-print filesList -- [["file1.mdx", "file2.css"], ["file3.mdx", "file4.png"]]
-
--- Filter the FileGroups where any file in the files list contains ".mdx"
-let mdict_filter = filter (\group -> any (isSuffixOf ".mdx") (files group)) fileGroups
-
--- Access all files of the filtered FileGroups
-let mdict_files = map files mdict_files
+### usage:
+``` shell
+$ ghc -o myprog examples/Main.hs -i./src
 ```
 
-you can for example, pass that list as a parameter for loading all of those dictionaries in [mdict-cpp](https://github.com/dictlab/mdict-cpp)
-
-TODO: move those functions to be some kind of helpers or operators

examples/Main.hs

@@ -1,7 +1,132 @@
-import KanaConv (convertHalfToFull)
+-- Copyright © 2025 Hashirama Senju
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BlockArguments #-}
+
+import GI.Gtk
+import qualified GI.Gtk as Gtk
+import GI.GLib (mainContextInvokeFull, MainContext)
+import GI.Gio hiding (Application)
+import Wazahs
+import Control.Concurrent
+import System.FilePath ((</>))
+import System.IO (writeFile)
+import Control.Concurrent.STM
+import System.Directory
+import qualified GI.WebKit.Objects.WebView as WK
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+
 
 main :: IO ()
 main = do
-  let input = "おいそこのｷﾐ｡あっはいはいはいは～い｡"
-  let output = convertHalfToFull input
-  putStrLn output
+    app <- new Application []
+
+    onApplicationActivate app $ do
+        window <- new GI.Gtk.ApplicationWindow [#application := app, #title := "Wazajisho"]
+        fd <- Gtk.fileDialogNew
+
+        home <- getHomeDirectory
+        let cfg = home </> ".local" </> "share" </> "wazajisho" </> "config"
+
+        filesVar <- newTVarIO []
+        
+        getFolderAsync fd window cfg $ \mPath -> case mPath of
+          Nothing -> putStrLn "Callback: no folder selected"
+          Just dir -> do
+            putStrLn $ "Callback: folder selected: " ++ dir
+            fs <- listFiles dir
+            putStrLn $ "Callback: listFiles found: " ++ show fs
+            atomically $ do
+              writeTVar filesVar fs
+
+
+        rootVBox <- Gtk.boxNew Gtk.OrientationVertical 6
+        topHBox  <- Gtk.boxNew Gtk.OrientationHorizontal 6
+        Gtk.widgetSetHexpand topHBox True
+        mainBox <- Gtk.boxNew Gtk.OrientationVertical 0
+
+        -- forces code to run in the same thread as gtk
+        mainContextInvokeFull Nothing 0 $ do
+            currentFiles <- readTVarIO filesVar
+            let icons = findIcons currentFiles
+            putStrLn "this was executed" -- well, it does works.
+            mapM_ putStrLn icons
+            toolbar <- createIconToolbar icons
+            Gtk.boxAppend mainBox toolbar
+            return False
+
+        
+        let htmlFilePath = "/tmp/index.html"
+        content <- TIO.readFile htmlFilePath
+        webview <- WK.webViewNew
+    
+        -- Load HTML content
+        WK.webViewLoadHtml webview content (Nothing :: Maybe T.Text)
+
+-- Main vertical box
+
+
+-- Toolbar
+
+
+            -- Search bar
+        searchBar <- new Gtk.Box
+          [ #orientation := Gtk.OrientationHorizontal
+          , #spacing := 20
+          , #baselinePosition := Gtk.BaselinePositionTop
+          , #halign := Gtk.AlignFill
+          , #hexpand := True
+          , #widthRequest := 300
+          , #marginTop := 10
+          , #marginEnd := 10
+          , #marginStart := 15
+          ]
+
+        entry <- Gtk.entryNew
+        Gtk.editableSetEditable entry True
+        #setHexpand entry True
+
+        searchButton <- new Gtk.Button [#label := "Search"]
+
+        Gtk.boxAppend searchBar entry
+        Gtk.boxAppend searchBar searchButton
+        Gtk.boxAppend mainBox searchBar
+
+        -- Phrase label (Yomichan-style heading)
+        phraseLabel <- new Gtk.Label [ #label := ("日本語の例文です" :: T.Text) ]
+        Gtk.widgetSetHalign phraseLabel Gtk.AlignCenter
+        Gtk.widgetSetHexpand phraseLabel True
+        #addCssClass phraseLabel "title-1"   -- large font style
+        Gtk.boxAppend mainBox phraseLabel
+
+        -- Webview
+        webviewBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
+        Gtk.boxAppend webviewBox webview
+        Gtk.widgetSetVexpand webview True
+        Gtk.widgetSetHexpand webview True
+        Gtk.boxAppend mainBox webviewBox
+
+
+      --  Gtk.boxAppend topHBox searchBar   -- search bar in top area
+
+-- keep your existing mainBox as the content area
+        Gtk.boxAppend rootVBox topHBox
+        Gtk.boxAppend rootVBox mainBox
+
+-- now set the window child to rootVBox (do this once)
+        Gtk.windowSetChild window (Just rootVBox)
+
+-- show
+        Gtk.widgetShow topHBox
+
+        Gtk.widgetShow rootVBox
+        Gtk.widgetShow window
+
+                      
+
+
+    applicationRun app Nothing
+    return ()

src/FileUtils.hs

@@ -1,127 +0,0 @@
--- Copyright © 2024 Hashirama Senju
-
-import System.Clock   -- To measure time
-import System.Console.ANSI  -- For colored output
---
-import Z.Data.CBytes (pack, unpack)
-import Z.IO.FileSystem (scandirRecursively)
-import System.FilePath (takeDirectory)
-import Data.List (groupBy, isSuffixOf, nub)
-import System.IO
-import qualified Data.Map as Map
-import Control.Concurrent.Async (mapConcurrently)
-import Control.Concurrent 
-
--- Derived version with automatic string handling
-scanDirectoryRecursivelyStr :: String -> IO [String]
-scanDirectoryRecursivelyStr path = do
-    result <- scandirRecursively (pack path) (\p _ -> return True)
-    return (map unpack result)  -- Ensures all results are decoded to Strings (UTF-8)
-
--- Function to filter files with a specific extension
-filterMdx :: [String] -> String -> [String]
-filterMdx files ext = filter (isSuffixOf ext) files
-
--- Custom implementation of takeDirectory for UTF-8 strings
-takeDirectory' :: String -> String
-takeDirectory' path = reverse . dropWhile (/= '/') . reverse $ path
-
-data FileGroup = FileGroup
-  { directory :: String   -- The directory part of the file path (UTF-8 String)
-  , files     :: [String] -- List of file paths in that directory (UTF-8 Strings)
-  } deriving (Show, Eq)
-
--- Create a map from directory to list of .mdx files
-groupMdxByDirectory :: [String] -> Map.Map String [String]
-groupMdxByDirectory mdxFiles = 
-  Map.fromListWith (++) [(takeDirectory' file, [file]) | file <- mdxFiles]
-
--- Group files by their directory, including additional files that belong to the same directory
-groupFilesByDirectory :: [String] -> [String] -> IO [FileGroup]
-groupFilesByDirectory mdxFiles additionalFiles = do
-  -- Create a map of directories to .mdx files
-  let mdxMap = groupMdxByDirectory mdxFiles
-  
-  -- Function to process each directory group in parallel
-  let processGroup dir mdxFilesInDir = do
-        let -- Filter additional files that belong to the same directory
-            additionalFilesInDir = filter (\f -> takeDirectory' f == dir) additionalFiles
-            -- Remove matching files from additional files (those that are already in the .mdx list)
-            remainingAdditionalFiles = filter (\f -> not (f `elem` mdxFilesInDir)) additionalFilesInDir
-            -- Combine and remove duplicates
-            allFiles = nub (mdxFilesInDir ++ remainingAdditionalFiles)
-        return $ FileGroup dir allFiles
-
-  -- Process each directory group concurrently
-  groupedFiles <- mapConcurrently (\(dir, mdxFilesInDir) -> processGroup dir mdxFilesInDir) (Map.toList mdxMap)
-  return groupedFiles
-  
--- Function to convert FileGroup to a string representation for file output
-fileGroupToString :: FileGroup -> String
-fileGroupToString (FileGroup dir files) = 
-    "Directory: " ++ dir ++ "\n" ++
-    unlines (map ("  " ++) files)
-
-
--- Box-like animation function with green color
-boxAnimation :: IO ()
-boxAnimation = do
-    let frames = ["[   ]", "[.  ]", "[ . ]", "[  .]"]  -- Frame progression for box
-    let loop frames' = do
-          mapM_ (\frame -> do
-            setSGR [SetColor Foreground Vivid Green]  -- Set the box color to green
-            putStr "\r"  -- Move cursor to the start of the line
-            putStr frame  -- Print the current frame
-            hFlush stdout  -- Flush output buffer
-            threadDelay 200000) frames'  -- Wait 0.2 seconds between frames
-          loop frames'  -- Recursively call to keep the loop running
-    loop frames  -- Start the looping animation
-
-
--- Main function
-main :: IO ()
-main = do
-
-        -- Start timing the operation
-    start <- getTime Monotonic
-
-    -- Notify the start of processing with color
-    setSGR [SetColor Foreground Vivid Blue]
-    putStrLn "Processing started..."
-    setSGR [Reset]  -- Reset colors
-        -- Create a thread for the box animation
-    animationThread <- forkIO boxAnimation
-
-  
-    allFiles <- scanDirectoryRecursivelyStr "/mnt/Data/Japanese_Resources/"
-    
-    -- Filter files with '.mdx' extension
-    let mdxFiles = filterMdx allFiles ".mdx"
-    
-    -- Group the files by their directories concurrently
-    groupedFiles <- groupFilesByDirectory mdxFiles allFiles
-
-    -- just to show that we finished processing, might be faster than doing I/O
-    putStrLn "Processing complete. Data is grouped."
-        -- Kill the animation thread
-    killThread animationThread
-            -- Stop timing the operation
-    end <- getTime Monotonic
-    let elapsed = toNanoSecs (diffTimeSpec end start) `div` 1000000  -- Convert to milliseconds
-
-    -- Show a colorful message after processing with elapsed time
-    setSGR [SetColor Foreground Vivid Green]
-    putStrLn $ "Processing complete. Time taken: " ++ show elapsed ++ " ms."
-    setSGR [Reset]  -- Reset colors
-
-    putStrLn "Starting to write results..."
-    animationThread <- forkIO boxAnimation
-    -- Open the output file and set its encoding to UTF-8
-    withFile "output.txt" WriteMode $ \handle -> do
-        hSetEncoding handle utf8  
-
-        -- Write the grouped files to the file
-        mapM_ (hPutStrLn handle . fileGroupToString) groupedFiles 
-
-    killThread animationThread
-

src/KanaConv.hs

@@ -1,36 +0,0 @@
--- Copyright © 2024 Hashirama Senju
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module KanaConv (convertHalfToFull) where  -- Export convertHalfToFull function
-
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-
--- The Kana mapping for half-width to full-width katakana
-halfToFullMapping :: Map.Map String String
-halfToFullMapping = Map.fromList
-  [ ("ｱ", "ア"), ("ｲ", "イ"), ("ｳ", "ウ"), ("ｴ", "エ"), ("ｵ", "オ")
-  , ("ｶ", "カ"), ("ｷ", "キ"), ("ｸ", "ク"), ("ｹ", "ケ"), ("ｺ", "コ")
-  , ("ｻ", "サ"), ("ｼ", "シ"), ("ｽ", "ス"), ("ｾ", "セ"), ("ｿ", "ソ")
-  , ("ﾀ", "タ"), ("ﾁ", "チ"), ("ﾂ", "ツ"), ("ﾃ", "テ"), ("ﾄ", "ト")
-  , ("ﾅ", "ナ"), ("ﾆ", "ニ"), ("ﾇ", "ヌ"), ("ﾈ", "ネ"), ("ﾉ", "ノ")
-  , ("ﾊ", "ハ"), ("ﾋ", "ヒ"), ("ﾌ", "フ"), ("ﾍ", "ヘ"), ("ﾎ", "ホ")
-  , ("ﾏ", "マ"), ("ﾐ", "ミ"), ("ﾑ", "ム"), ("ﾒ", "メ"), ("ﾓ", "モ")
-  , ("ﾤ", "ヤ"), ("ﾦ", "ユ"), ("ﾧ", "ヨ"), ("ﾨ", "ラ"), ("ﾩ", "リ")
-  , ("ﾪ", "ル"), ("ﾬ", "レ"), ("ﾮ", "ロ"), ("ﾜ", "ワ"), ("ｦ", "ヲ")
-  , ("ﾝ", "ン"), ("ｧ", "ァ"), ("ｨ", "ィ"), ("ｩ", "ゥ"), ("ｪ", "ェ")
-  , ("ｫ", "ォ"), ("ｯ", "ッ"), ("ｬ", "ャ"), ("ｭ", "ュ"), ("ｮ", "ョ")
-  , ("｡", "。"), ("､", "、"), ("･", "・"), ("゛", "ﾞ"), ("゜", "ﾟ")
-  , ("｢", "「"), ("｣", "」"), ("ｰ", "ー")
-  ]
-
--- Function to replace half-width characters with full-width characters
-replaceChar :: Char -> String
-replaceChar char
-  | Just full <- Map.lookup [char] halfToFullMapping = full
-  | otherwise = [char]
-
--- Function to convert the entire string
-convertHalfToFull :: String -> String
-convertHalfToFull = concatMap replaceChar

src/Keyboard.hs

@@ -1,12 +0,0 @@
-import Data.Text.Lazy             as TL
-
-parseKB :: [String] -> [String]
-parseKB keylist = do {-
-        the thing is, we need to process this as a list, maybe with Map
--}
-  our_keylist = TL.pack keylist
-  our_operator = TL.pack "-"
-  splited = TL.unpack $ TL.splitOn our_operator our_keylist
-
--- getting the keys is partially implemented here:
--- https://git.ajattix.org/hashirama/haskell-examples/src/branch/main/keyPress.hs

src/Wazahs.hs

@@ -0,0 +1,252 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Wazahs (
+    listFiles,
+    selectFolder,
+    getFolderAsync,
+    createIconToolbar,
+    findIcons,
+    (<@),
+    attachDialogOnRealize
+) where
+
+-- imports
+
+import qualified Data.Conduit.Combinators as CC
+import GI.Gtk
+import GI.GLib (mainContextInvokeFull)
+import GI.Gio hiding (Application)
+import qualified GI.Gtk as GTK
+import qualified GI.Gtk as Gtk
+import qualified GI.Gdk as Gdk
+import qualified GI.GdkX11 as GdkX11
+import Data.GI.Base.Signals
+import Data.GI.Base (castTo)
+import Foreign.Marshal.Array (withArray)
+import Foreign.Ptr (castPtr)
+import Foreign.C.Types (CULong)
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras (xChangeProperty, propModeReplace)
+import Control.Monad      (when, void, mzero, guard)
+import Data.Foldable      (for_)
+import System.Directory   
+import System.FilePath
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Data.Conduit
+import System.Environment 
+import Control.Concurrent
+import System.IO (writeFile)
+import Conduit
+import System.Process
+import qualified Data.Text as T
+import qualified Data.Map as M
+import System.Exit
+
+-- | Recursively list all files in the given directory with .mdx extension.
+listFiles :: FilePath -> IO [FilePath]
+listFiles dir = runConduitRes $
+       CC.sourceDirectoryDeep False dir
+  .|   filterC (\fp -> takeExtension fp == ".mdx")
+  .|   sinkList
+
+-- | Helper function for selecting folders in gtk
+selectFolder :: FileDialog -> ApplicationWindow -> (Maybe String -> IO ()) -> IO ()
+selectFolder fd w k =
+  fileDialogSelectFolder fd (Just w) (Nothing :: Maybe Cancellable) $ Just $ \_ r -> do
+    mbPath <- runMaybeT $ do
+      f <- MaybeT $ handleDialogError (\_ _ -> pure Nothing) (fileDialogSelectFolderFinish fd r)
+      p <- MaybeT $ fileGetPath f
+      p <$ (liftIO (doesDirectoryExist p) >>= guard)
+    k mbPath
+
+-- Blocking: returns Maybe FilePath (checks config first).
+-- WARNING: don't call on GTK main thread (it will block the dialog).
+getFolderBlocking
+  :: FileDialog           -- dialog (created by caller)
+  -> ApplicationWindow    -- parent (created by caller)
+  -> FilePath             -- config file path
+  -> IO (Maybe FilePath)
+getFolderBlocking fd w configFile = do
+  -- check config
+  cfgOk <- doesFileExist configFile
+  if cfgOk
+    then do
+      path <- readFile configFile
+      ok <- doesDirectoryExist path
+      if ok then return (Just path) else prompt
+    else prompt
+ where
+  prompt = do
+    mv <- newEmptyMVar
+    -- use the existing callback-style selectFolder
+    selectFolder fd w $ \mPath -> do
+      case mPath of
+        Nothing -> putMVar mv Nothing
+        Just p  -> do
+          createDirectoryIfMissing True (takeDirectory configFile)
+          writeFile configFile p
+          putMVar mv (Just p)
+    takeMVar mv
+
+
+-- | Restart the current program
+restartProgram :: IO ()
+restartProgram = do
+    exePath <- getExecutablePath
+    _ <- spawnProcess exePath []  -- launch a new instance
+    exitSuccess                  -- exit this instance
+
+
+-- Async: safe to call from GTK main thread. Calls k with result.
+getFolderAsync
+  :: FileDialog
+  -> ApplicationWindow
+  -> FilePath
+  -> (Maybe FilePath -> IO ())   -- callback to receive result
+  -> IO ()
+getFolderAsync fd w configFile k = do
+  cfgOk <- doesFileExist configFile
+  if cfgOk
+    then do
+      path <- readFile configFile
+      ok <- doesDirectoryExist path
+      if ok
+        then k (Just path)
+        else showDialog
+    else showDialog
+ where
+  showDialog = selectFolder fd w $ \mPath -> case mPath of
+    Nothing -> k Nothing
+    Just p  -> do
+      createDirectoryIfMissing True (takeDirectory configFile)
+      writeFile configFile p
+      k (Just p)
+      restartProgram
+
+
+-- Return all icons corresponding to .mdx files
+findIcons :: [FilePath] -> [FilePath]
+findIcons files = [replaceExtension f "png" | f <- files, takeExtension f == ".mdx"]
+
+
+-- not related to file handling:
+createIconToolbar' :: [FilePath] -> IO Gtk.Box
+createIconToolbar' iconPaths = do
+    toolbar <- Gtk.boxNew Gtk.OrientationHorizontal 0
+    Gtk.widgetSetHalign toolbar Gtk.AlignCenter
+    Gtk.widgetSetValign toolbar Gtk.AlignCenter
+
+    cssProvider <- Gtk.cssProviderNew
+    Gtk.cssProviderLoadFromString cssProvider $ T.pack $
+        ".classic-button {"
+        ++ "  -gtk-appearance: none;"
+        ++ "  background-image: linear-gradient(to bottom, #f3f3f3, #d8d8d8);"
+        ++ "  border: 1px solid #bbb;"
+        ++ "  border-radius: 4px;"
+        ++ "  color: #333;"
+        ++ "  box-shadow: inset 0 1px 0 rgba(255,255,255,0.7);"
+        ++ "  padding: 4px 8px;"
+        ++ "}"
+        ++ ".classic-button:hover {"
+        ++ "  background-image: linear-gradient(to bottom, #e6e6e6, #ccc);"
+        ++ "}"
+        ++ ".classic-button:active {"
+        ++ "  background-image: linear-gradient(to bottom, #ccc, #e6e6e6);"
+        ++ "}"
+
+    
+    mapM_ (\path -> do
+        icon <- Gtk.imageNewFromFile path
+        Gtk.widgetSetSizeRequest icon 64 64  -- Force minimum size
+
+        btn <- Gtk.buttonNew
+        Gtk.widgetAddCssClass btn "glass-button"
+        Gtk.widgetSetSizeRequest btn 80 80   -- Button size (icon + padding)
+        Gtk.widgetSetHalign btn Gtk.AlignCenter
+        Gtk.widgetSetValign btn Gtk.AlignCenter
+        Gtk.buttonSetChild btn (Just icon)
+        
+        -- Add click handler
+        void $ Gtk.on btn #clicked $ do
+            putStrLn $ "Selected: " ++ path
+            -- Add your click handler logic here
+            
+        Gtk.boxAppend toolbar btn
+        ) iconPaths
+    
+    return toolbar
+
+
+
+-- Wrap the toolbar in a ScrolledWindow that scrolls horizontally
+createIconToolbar :: [FilePath] -> IO Gtk.Widget
+createIconToolbar iconPaths = do
+    -- Get your original toolbar (horizontal box)
+    toolbar <- createIconToolbar' iconPaths
+    
+    -- Create a new scrolled window
+    scrolled <- Gtk.scrolledWindowNew
+    
+    -- Show the horizontal scrollbar automatically, never show the vertical one
+    Gtk.scrolledWindowSetPolicy scrolled Gtk.PolicyTypeAutomatic Gtk.PolicyTypeNever
+
+    -- Put the horizontal box (your toolbar) inside the scrolled window
+    Gtk.scrolledWindowSetChild scrolled (Just toolbar)
+    
+    -- Return as a general Widget
+    Gtk.toWidget scrolled
+
+-- helper for forcing lambdas to run in the gtk thread:
+infixr 0 <@
+(<@) :: IO () -> IO ()
+(<@) action = mainContextInvokeFull Nothing 0 $ do
+    action
+    return False
+
+
+-- | Set _NET_WM_WINDOW_TYPE to _NET_WM_WINDOW_TYPE_DIALOG for a realized GTK window.
+--   Safe to call from the GTK main thread after the window has a surface (i.e. after realize).
+setWindowAsDialog :: Gtk.IsWindow w => w -> IO ()
+setWindowAsDialog win = do
+  -- upcast to concrete Gtk.Window right away (resolves ambiguity)
+  wnd <- Gtk.toWindow win
+
+  -- now get surface with a concrete Window type in scope
+  mSurface <- #getSurface wnd
+  case mSurface of
+    Just (surface :: Gdk.Surface) -> do
+      -- cast to GDK X11 surface & display (explicit IO results)
+      mX11Surface <- (castTo GdkX11.X11Surface surface) :: IO (Maybe GdkX11.X11Surface)
+      display     <- Gdk.surfaceGetDisplay surface
+      mX11Display <- (castTo GdkX11.X11Display display) :: IO (Maybe GdkX11.X11Display)
+
+      case (mX11Display, mX11Surface) of
+        (Just _gdkX11Disp, Just x11Surf) -> do
+          -- get window XID and set ATOM via X11
+          xidCULong <- GdkX11.x11SurfaceGetXid x11Surf
+
+          dpy <- openDisplay ""
+          atomType   <- internAtom dpy "_NET_WM_WINDOW_TYPE" False
+          atomDialog <- internAtom dpy "_NET_WM_WINDOW_TYPE_DIALOG" False
+          atomAtom   <- internAtom dpy "ATOM" False
+
+          withArray [atomDialog] $ \ptr -> do
+            let winX :: Window
+                winX = fromIntegral (xidCULong :: CULong)
+            void $ xChangeProperty dpy winX atomType atomAtom 32 propModeReplace (castPtr ptr) 1
+            flush dpy
+
+          closeDisplay dpy
+        _ -> putStrLn "Not running under X11."
+    Nothing -> putStrLn "No surface available"
+
+-- | Attach setting the dialog atom to the window's #realize signal.
+--   Returns the SignalHandlerId so you can disconnect if needed.
+attachDialogOnRealize :: Gtk.IsWindow w => w -> IO SignalHandlerId
+attachDialogOnRealize win = do
+  wnd <- Gtk.toWindow win
+  on wnd #realize (setWindowAsDialog win)