diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 0c6ef49..0000000 --- a/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -# .gitignore - - -*~ -*# -.#* -*rej -*orig -pinentry* -*.hi -*.o -*.a \ No newline at end of file diff --git a/README.md b/README.md index a24bb0e..af69d0e 100644 --- a/README.md +++ b/README.md @@ -5,9 +5,26 @@ wazajisho library for handling japanese text in haskell cover +### FileUtils.h -### usage: -``` shell -$ ghc -o myprog examples/Main.hs -i./src +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 ``` +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 5b95fa7..7146c80 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -1,132 +1,7 @@ --- 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 - +import KanaConv (convertHalfToFull) main :: IO () main = do - 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 () + let input = "おいそこのｷﾐ｡あっはいはいはいは～い｡" + let output = convertHalfToFull input + putStrLn output diff --git a/src/FileUtils.hs b/src/FileUtils.hs new file mode 100644 index 0000000..c80ad6c --- /dev/null +++ b/src/FileUtils.hs @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 0000000..4cd1962 --- /dev/null +++ b/src/KanaConv.hs @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 0000000..41bbd2e --- /dev/null +++ b/src/Keyboard.hs @@ -0,0 +1,12 @@ +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 deleted file mode 100644 index 2f6dc0c..0000000 --- a/src/Wazahs.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# 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)