diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0c6ef49 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +# .gitignore + + +*~ +*# +.#* +*rej +*orig +pinentry* +*.hi +*.o +*.a \ No newline at end of file diff --git a/README.md b/README.md index af69d0e..a24bb0e 100644 --- a/README.md +++ b/README.md @@ -5,26 +5,9 @@ wazajisho library for handling japanese text in haskell cover -### 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 \ No newline at end of file diff --git a/examples/Main.hs b/examples/Main.hs index 7146c80..5b95fa7 100644 --- a/examples/Main.hs +++ b/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 () diff --git a/src/FileUtils.hs b/src/FileUtils.hs deleted file mode 100644 index c80ad6c..0000000 --- a/src/FileUtils.hs +++ /dev/null @@ -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 - diff --git a/src/KanaConv.hs b/src/KanaConv.hs deleted file mode 100644 index 4cd1962..0000000 --- a/src/KanaConv.hs +++ /dev/null @@ -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 diff --git a/src/Keyboard.hs b/src/Keyboard.hs deleted file mode 100644 index 41bbd2e..0000000 --- a/src/Keyboard.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/src/Wazahs.hs b/src/Wazahs.hs new file mode 100644 index 0000000..2f6dc0c --- /dev/null +++ b/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)