From fad03365155308344b69f75d4b745740b69082c5 Mon Sep 17 00:00:00 2001 From: hashirama Date: Thu, 30 Jan 2025 18:04:09 +0000 Subject: [PATCH 01/23] WIP --- src/Keyboard.hs | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 src/Keyboard.hs diff --git a/src/Keyboard.hs b/src/Keyboard.hs new file mode 100644 index 0000000..9fbc517 --- /dev/null +++ b/src/Keyboard.hs @@ -0,0 +1,9 @@ +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 From 774e42f434da52cbaffd82f04c043c77a9294a2e Mon Sep 17 00:00:00 2001 From: hashirama Date: Fri, 14 Feb 2025 02:26:59 +0000 Subject: [PATCH 02/23] add parser this implements a way of loading our previous created file, which will work as a cache to avoid computing things again. we also need to implement a function to check whether the directory changed before attempting to load our cache, otherwise the cache can be outdated. --- src/FileUtils.hs | 55 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/src/FileUtils.hs b/src/FileUtils.hs index c80ad6c..5616d6f 100644 --- a/src/FileUtils.hs +++ b/src/FileUtils.hs @@ -6,11 +6,13 @@ 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 Data.List (groupBy, isSuffixOf, isPrefixOf nub) import System.IO import qualified Data.Map as Map import Control.Concurrent.Async (mapConcurrently) import Control.Concurrent +import Control.Monad +import Data.Char (isSpace) -- Derived version with automatic string handling scanDirectoryRecursivelyStr :: String -> IO [String] @@ -78,6 +80,57 @@ boxAnimation = do loop frames -- Start the looping animation + +-- A simple trim function to remove leading/trailing whitespace +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- Process lines to produce a list of (directory, [file paths]) tuples. +-- It ignores lines until the first "Directory:" is found (and discards it), +-- then uses subsequent "Directory:" lines to start new groups. +processLines :: [String] -> [(String, [String])] +processLines = reverse . go False [] + where + -- The Bool flag indicates whether we've encountered the first "Directory:" line. + go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] + go _ acc [] = acc + -- Before the first "Directory:" has been seen: + go False acc (line:rest) + | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. + | otherwise = go False acc rest + -- After the first "Directory:" has been skipped, but before starting any group: + go True [] (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True [(dir, [])] rest + | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. + -- When a group has been started: + go True ((currentDir, files):xs) (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True ((dir, []):(currentDir, files):xs) rest + | otherwise = + go True ((currentDir, files ++ [trim line]) : xs) rest + + +{- +this should be used that way: + + result <- getData "output.txt" + let finalresult = processLines result -- that way we maintain purity +-} + +getData :: FilePath -> IO [String] +getData f = do + content <- readFile f + return (lines content) + + + + + + -- Main function main :: IO () main = do From 855db174b18a2ead8d50568b1b94e00a289016e5 Mon Sep 17 00:00:00 2001 From: hashirama Date: Fri, 14 Feb 2025 02:35:39 +0000 Subject: [PATCH 03/23] colon --- src/FileUtils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FileUtils.hs b/src/FileUtils.hs index 5616d6f..f21155f 100644 --- a/src/FileUtils.hs +++ b/src/FileUtils.hs @@ -6,7 +6,7 @@ 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, isPrefixOf nub) +import Data.List (groupBy, isSuffixOf, isPrefixOf, nub) import System.IO import qualified Data.Map as Map import Control.Concurrent.Async (mapConcurrently) From 437cad94a668f124aa0eef443db03f9b3a32b704 Mon Sep 17 00:00:00 2001 From: hashirama Date: Mon, 24 Feb 2025 00:16:34 +0000 Subject: [PATCH 04/23] Update src/Keyboard.hs --- src/Keyboard.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Keyboard.hs b/src/Keyboard.hs index 9fbc517..41bbd2e 100644 --- a/src/Keyboard.hs +++ b/src/Keyboard.hs @@ -7,3 +7,6 @@ parseKB keylist = do {- 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 From 00eab63c751696e517b0597e32e058e2614da56c Mon Sep 17 00:00:00 2001 From: hashirama Date: Thu, 20 Mar 2025 01:31:43 +0000 Subject: [PATCH 05/23] Add src/getIcons.hs --- src/getIcons.hs | 161 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 161 insertions(+) create mode 100644 src/getIcons.hs diff --git a/src/getIcons.hs b/src/getIcons.hs new file mode 100644 index 0000000..79fd795 --- /dev/null +++ b/src/getIcons.hs @@ -0,0 +1,161 @@ +-- 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, dropExtension, takeExtension) +import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find) +import System.IO +import qualified Data.Map as Map +import Control.Concurrent.Async (mapConcurrently) +import Control.Concurrent +import Control.Monad +import Data.Char (isSpace) +import Data.Maybe (mapMaybe, maybeToList) + + +type FileList = [(String, [String])] -- (Directory, Files) + +extractIcons :: FileList -> [String] -- List of icon paths +extractIcons = concatMap processGroup + where + processGroup (_, files) = maybeToList (findIcon files) + +findIcon :: [String] -> Maybe String +findIcon files = do + mdxFile <- find isMdxFile files + let baseName = dropExtension mdxFile + find (isIconFile baseName) files + where + isMdxFile file = takeExtension file == ".mdx" + isIconFile base file = + dropExtension file == base && + takeExtension file `elem` imageExtensions + +imageExtensions :: [String] +imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"] + + + +-- 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 + + + +-- A simple trim function to remove leading/trailing whitespace +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- Process lines to produce a list of (directory, [file paths]) tuples. +-- It ignores lines until the first "Directory:" is found (and discards it), +-- then uses subsequent "Directory:" lines to start new groups. +processLines :: [String] -> [(String, [String])] +processLines = reverse . go False [] + where + -- The Bool flag indicates whether we've encountered the first "Directory:" line. + go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] + go _ acc [] = acc + -- Before the first "Directory:" has been seen: + go False acc (line:rest) + | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. + | otherwise = go False acc rest + -- After the first "Directory:" has been skipped, but before starting any group: + go True [] (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True [(dir, [])] rest + | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. + -- When a group has been started: + go True ((currentDir, files):xs) (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True ((dir, []):(currentDir, files):xs) rest + | otherwise = + go True ((currentDir, files ++ [trim line]) : xs) rest + + + +getData :: FilePath -> IO [String] +getData f = do + content <- readFile f + return (lines content) + + + +main :: IO () +main = do + -- Get raw data through IO + rawData <- getData "output.txt" + + -- Pure transformations + let processed = processLines rawData + let icons = extractIcons processed + + -- Output results + mapM_ putStrLn icons + From 76f1aafa8e56231409427d278b3d3027f34f51c6 Mon Sep 17 00:00:00 2001 From: hashirama Date: Mon, 24 Mar 2025 20:00:11 +0000 Subject: [PATCH 06/23] add non-working version of make_package.hs for further refactoring. --- src/make_package.hs | 208 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 208 insertions(+) create mode 100644 src/make_package.hs diff --git a/src/make_package.hs b/src/make_package.hs new file mode 100644 index 0000000..7d063b3 --- /dev/null +++ b/src/make_package.hs @@ -0,0 +1,208 @@ +-- currently not working, needs refactoring. + +import Control.Exception (bracket_) +import qualified Control.Lens as Lens +import Control.Lens.Operators +import Control.Monad (when, unless, filterM) +import Data.Foldable (traverse_) +import qualified System.Directory as Dir +import qualified System.Environment as Env +import System.FilePath ((), takeFileName, takeDirectory) +import qualified System.Info as SysInfo +import System.Process (readProcess, callProcess) + +import Prelude + +interestingLibs :: [String] +interestingLibs = + [ "libGLEW" + , "libGLU" + , "libXcursor" + , "libXi" + , "libXinerama" + , "libXrandr" + , "libXrender" + , "libbsd" + , "libbz2" + , "libcares" + , "libcrypto" + , "libdw" + , "libelf" + , "libgflags" + , "libgmp" + , "libicudata" + , "libicui18n" + , "libicuuc" + , "liblzma" + , "libnghttp2" + , "libnode" + , "librocksdb" + , "libsnappy" + , "libssl" + , "libuv" + ] + +isInteresting :: FilePath -> Bool +isInteresting path = + baseName `elem` interestingLibs + where + -- takeBaseName removes one extension, we remove all: + baseName = takeFileName path & takeWhile (/= '.') + +parseLddOut :: String -> [FilePath] +parseLddOut lddOut = + lines lddOut + >>= parseLine + & filter isInteresting + where + parseLine line = + case words line & dropWhile (/= "=>") of + [] -> [] + "=>":libPath:_ -> [libPath] + _ -> error "unexpected break output" + +otoolMinMacosVersion :: FilePath -> IO Float +otoolMinMacosVersion path = + readProcess "otool" ["-l", path] "" <&> + (^?! Lens.to lines . traverse . + Lens.to words . + Lens.filteredBy (Lens.ix 0 . (Lens.only "minos" <> Lens.only "version")) . + Lens.ix 1 . Lens._Show) + +-- Use `otool` to recursively find macOS deps +findDylibs :: FilePath -> IO [FilePath] +findDylibs path = + do + deps <- + readProcess "otool" ["-L", path] "" + <&> lines <&> tail <&> map words <&> (>>= take 1) + <&> filter (/= path) + >>= filterM Dir.doesPathExist + traverse findDylibs deps <&> concat <&> (deps <>) + +-- Slightly nicer syntax than using a sum type with case everywhere +isMacOS :: Bool +isMacOS = SysInfo.os == "darwin" + +isWindows :: Bool +isWindows = SysInfo.os == "mingw32" + +isLinux :: Bool +isLinux = SysInfo.os == "linux" + +pkgDir :: FilePath +pkgDir + | isMacOS = "Lamdu.app" + | otherwise = "lamdu" + +toPackageWith :: FilePath -> FilePath -> IO () +toPackageWith srcPath relPath = + do + putStrLn $ "Packaging " ++ srcPath ++ " to " ++ destPath + Dir.createDirectoryIfMissing True (takeDirectory destPath) + callProcess "cp" ["-aLR", srcPath, destPath] + where + destPath = contentsDir relPath + contentsDir + | isMacOS = pkgDir "Contents" + | otherwise = pkgDir + +toPackage :: FilePath -> IO () +toPackage srcPath = toPackageWith srcPath (takeFileName srcPath) + +libToPackage :: FilePath -> IO () +libToPackage srcPath = + toPackageWith srcPath (dir filename) + where + filename = takeFileName srcPath + dir + | isWindows = "." + | isMacOS = "MacOS" + | otherwise = "lib" + +findDeps :: String -> IO [FilePath] +findDeps exec + | isWindows = + [ "libwinpthread-1.dll" + , "libstdc++-6.dll" + , "libgcc_s_seh-1.dll" + , "librocksdb.dll" + , "libbz2-1.dll" + , "liblz4.dll" + , "zlib1.dll" + , "libzstd.dll" + ] <&> ("/mingw64/bin" ) + & pure + | isMacOS = + findDylibs exec + | otherwise = + readProcess "ldd" [exec] "" <&> parseLddOut + +fixDylibPaths :: FilePath -> IO () +fixDylibPaths targetName = + findDylibs target >>= + traverse_ fixDep + where + target = pkgDir "Contents" "MacOS" targetName + fixDep dep = + do + callProcess "chmod" ["+w", target] + callProcess "install_name_tool" + ["-change", dep, "@executable_path/" ++ takeFileName dep, target] + +parseLamduVersion :: String -> String +parseLamduVersion info = + case lines info <&> words of + (["Lamdu", result]:_) -> result + _ -> error "failed parsing version number" + +whichCmd :: String +whichCmd + | isWindows = "where" + | otherwise = "which" + +main :: IO () +main = + do + [lamduExec] <- Env.getArgs + nodePath <- readProcess whichCmd ["node"] "" <&> takeWhile (`notElem` "\r\n") + nodeDeps <- findDeps nodePath + when isMacOS $ + do + unless (null nodeDeps) $ fail "nodejs not statically linked!" + minos <- otoolMinMacosVersion lamduExec + when (minos > 10.9) (fail "Lamdu executable only runs on new macOS versions") + version <- readProcess lamduExec ["--version"] "" <&> parseLamduVersion + lamduDeps <- findDeps lamduExec + let allDeps = nodeDeps <> lamduDeps + bracket_ (Dir.createDirectory pkgDir) (unless isMacOS (Dir.removeDirectoryRecursive pkgDir)) $ + do + toPackageWith lamduExec destPath + toPackageWith "data" dataDir + toPackageWith nodePath (dataDir "bin/node.exe") + traverse_ libToPackage allDeps + when isWindows $ + callProcess "iscc.exe" ["/Flamdu-" ++ version ++ "-win-setup", "tools\\data\\lamdu.iss"] + when isLinux $ + do + toPackage "tools/data/run-lamdu.sh" + callProcess "tar" ["-c", "-z", "-f", "lamdu-" ++ version ++ "-linux.tgz", pkgDir] + when isMacOS $ + do + toPackage "tools/data/Info.plist" + traverse_ fixDylibPaths ("lamdu" : (allDeps <&> takeFileName)) + callProcess "sh" + [ "tools/data/macos_icon.sh" + , "data/Lamdu.png" + , pkgDir "Contents" "Resources" "lamdu.icns" + ] + -- The next steps of signing, notarization, and stapling happen in a seperate script + putStrLn "Done" + where + destPath + | isWindows = "lamdu.exe" + | isMacOS = "MacOS/lamdu" + | otherwise = "bin/lamdu" + dataDir + | isMacOS = "Resources" + | otherwise = "data" From c1281176937a52a0555290826a5874b523f219e7 Mon Sep 17 00:00:00 2001 From: hashirama Date: Mon, 28 Apr 2025 16:29:29 +0000 Subject: [PATCH 07/23] Add src/IconToolbar.hs --- src/IconToolbar.hs | 290 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 290 insertions(+) create mode 100644 src/IconToolbar.hs diff --git a/src/IconToolbar.hs b/src/IconToolbar.hs new file mode 100644 index 0000000..d0a2a67 --- /dev/null +++ b/src/IconToolbar.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-} +-- Copyright © 2025 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, dropExtension, takeExtension) +import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find) +import System.IO +import qualified Data.Map as Map +import Control.Concurrent.Async (mapConcurrently) +import Control.Concurrent +import Control.Monad +import Data.Char (isSpace) +import Data.Maybe (mapMaybe, maybeToList) + + +import qualified GI.Gtk as Gtk +import GI.Gtk (Grid(..), Image(..), Orientable(..)) +import GI.Gio +import Control.Monad (void) +import qualified Data.Text as T + + +{-# LANGUAGE OverloadedStrings #-} + +import qualified GI.Gtk as Gtk +import GI.Gtk (AttrOp((:=))) +import Data.Text (Text) +import qualified Data.Text as T + +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 + +--- + +type FileList = [(String, [String])] -- (Directory, Files) + +extractIcons :: FileList -> [String] -- List of icon paths +extractIcons = concatMap processGroup + where + processGroup (_, files) = maybeToList (findIcon files) + +findIcon :: [String] -> Maybe String +findIcon files = do + mdxFile <- find isMdxFile files + let baseName = dropExtension mdxFile + find (isIconFile baseName) files + where + isMdxFile file = takeExtension file == ".mdx" + isIconFile base file = + dropExtension file == base && + takeExtension file `elem` imageExtensions + +imageExtensions :: [String] +imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"] + + + +-- 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 + + + +-- A simple trim function to remove leading/trailing whitespace +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- Process lines to produce a list of (directory, [file paths]) tuples. +-- It ignores lines until the first "Directory:" is found (and discards it), +-- then uses subsequent "Directory:" lines to start new groups. +processLines :: [String] -> [(String, [String])] +processLines = reverse . go False [] + where + -- The Bool flag indicates whether we've encountered the first "Directory:" line. + go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] + go _ acc [] = acc + -- Before the first "Directory:" has been seen: + go False acc (line:rest) + | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. + | otherwise = go False acc rest + -- After the first "Directory:" has been skipped, but before starting any group: + go True [] (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True [(dir, [])] rest + | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. + -- When a group has been started: + go True ((currentDir, files):xs) (line:rest) + | "Directory:" `isPrefixOf` line = + let dir = trim (drop 11 line) + in go True ((dir, []):(currentDir, files):xs) rest + | otherwise = + go True ((currentDir, files ++ [trim line]) : xs) rest + + +{- +this should be used that way: + + result <- getData "output.txt" + let finalresult = processLines result -- that way we maintain purity +-} + +getData :: FilePath -> IO [String] +getData f = do + content <- readFile f + return (lines content) + + + +main :: IO () +main = do + + +-- Function that builds the cache +{- 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 + + + putStrLn "Starting to write results..." + + -- 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 + + + putStrLn "Finished." +-} + -- Get raw data through IO + rawData <- getData "output.txt" + + -- Pure transformations + let processed = processLines rawData + let icons = extractIcons processed + + -- Output results + mapM_ putStrLn icons + + app <- Gtk.applicationNew (Just "com.example.DictionaryIcons") [] + + void $ Gtk.on app #activate $ do + window <- Gtk.applicationWindowNew app + Gtk.windowSetTitle window (Just "Dictionary Toolbar") -- Fixed line + Gtk.windowSetDefaultSize window 800 100 + + -- Rest of the code remains the same + + mainBox <- Gtk.boxNew Gtk.OrientationVertical 0 + toolbar <- createIconToolbar icons + + Gtk.boxAppend mainBox toolbar + Gtk.windowSetChild window (Just mainBox) + Gtk.widgetShow window + + _ <- applicationRun app Nothing + return () + From 5ba10e7cddc77eace8fbcca3841feec83b339d5a Mon Sep 17 00:00:00 2001 From: hashirama Date: Thu, 29 May 2025 03:56:40 +0000 Subject: [PATCH 08/23] Add src/getDictionaries.hs --- src/getDictionaries.hs | 53 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 src/getDictionaries.hs diff --git a/src/getDictionaries.hs b/src/getDictionaries.hs new file mode 100644 index 0000000..787041c --- /dev/null +++ b/src/getDictionaries.hs @@ -0,0 +1,53 @@ +-- Copyright © 2025 Hashirama Senju + +{-# LANGUAGE OverloadedStrings #-} + +import Prelude hiding (FilePath) +import System.IO (hSetEncoding, stdout, utf8) +import System.FilePath ((), takeDirectory) +import qualified System.FilePath as FP +import Filesystem.Path.CurrentOS (FilePath, encodeString, decodeString) +import qualified Filesystem.Path.CurrentOS as FP +import qualified Filesystem as FS +import qualified Data.Text as T + +import Pipes +import Pipes.Safe (runSafeT, MonadSafe) +import Data.DirStream +import Control.Monad.State.Strict +import qualified Data.HashMap.Strict as HM +import qualified Data.Text.IO as TIO +import Data.Maybe (fromMaybe) + +import Control.Monad (when, filterM) +import Data.List (sort) + +type MdxIndex = HM.HashMap String (FilePath, [FilePath]) + + + +main :: IO () +main = do + hSetEncoding stdout utf8 + mdxMap <- execStateT (runSafeT $ runEffect pipeline) (HM.empty :: MdxIndex) + + -- print everything + forM_ (HM.toList mdxMap) $ \(mdx, (folder, files)) -> do + TIO.putStrLn $ "MDX: " <> T.pack mdx + TIO.putStrLn $ "Folder: " <> T.pack (encodeString folder) + mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files) + + mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files) + TIO.putStrLn "" + +pipeline :: forall m. (MonadSafe m, MonadState MdxIndex m, MonadFail m) => Effect m () +pipeline = + for (every (descendentOf "/mnt/Data/Japanese_Resources/Dictionaries/")) $ \fp -> + when (FP.extension fp == Just "mdx") $ do + let folder = FP.directory fp + allFiles <- liftIO $ FS.listDirectory folder + modify' (HM.insert (encodeString fp) (folder, allFiles)) + + + + From 13b81bc1ce09454e0f1eb0e43e30235eda2e01d1 Mon Sep 17 00:00:00 2001 From: hashirama Date: Thu, 29 May 2025 04:03:10 +0000 Subject: [PATCH 09/23] Update src/getDictionaries.hs --- src/getDictionaries.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/getDictionaries.hs b/src/getDictionaries.hs index 787041c..8c7e4b2 100644 --- a/src/getDictionaries.hs +++ b/src/getDictionaries.hs @@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe) import Control.Monad (when, filterM) import Data.List (sort) +-- needs a dedup type MdxIndex = HM.HashMap String (FilePath, [FilePath]) From 40bb31e9a8b3399e9c27fbaa67e266459d097b2d Mon Sep 17 00:00:00 2001 From: hashirama Date: Thu, 29 May 2025 04:59:50 +0000 Subject: [PATCH 10/23] Update src/getDictionaries.hs --- src/getDictionaries.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/getDictionaries.hs b/src/getDictionaries.hs index 8c7e4b2..c845127 100644 --- a/src/getDictionaries.hs +++ b/src/getDictionaries.hs @@ -22,11 +22,9 @@ import Data.Maybe (fromMaybe) import Control.Monad (when, filterM) import Data.List (sort) --- needs a dedup type MdxIndex = HM.HashMap String (FilePath, [FilePath]) - main :: IO () main = do hSetEncoding stdout utf8 @@ -38,7 +36,6 @@ main = do TIO.putStrLn $ "Folder: " <> T.pack (encodeString folder) mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files) - mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files) TIO.putStrLn "" pipeline :: forall m. (MonadSafe m, MonadState MdxIndex m, MonadFail m) => Effect m () From 2277a8a59f82857e99537c33f94dd13dc58ada08 Mon Sep 17 00:00:00 2001 From: hashirama Date: Fri, 12 Sep 2025 21:36:11 -0400 Subject: [PATCH 11/23] fix & update --- README.md | 23 +--- examples/Main.hi | Bin 0 -> 3053 bytes examples/Main.hs | 9 +- examples/Main.o | Bin 0 -> 4424 bytes src/FileUtils.hs | 180 ------------------------- src/IconToolbar.hs | 290 ----------------------------------------- src/KanaConv.hs | 36 ----- src/Wazahs.hi | Bin 0 -> 3375 bytes src/Wazahs.hs | 19 +++ src/Wazahs.hs~ | 19 +++ src/Wazahs.o | Bin 0 -> 8152 bytes src/getDictionaries.hs | 51 -------- src/getIcons.hs | 161 ----------------------- src/make_package.hs | 208 ----------------------------- 14 files changed, 46 insertions(+), 950 deletions(-) create mode 100644 examples/Main.hi create mode 100644 examples/Main.o delete mode 100644 src/FileUtils.hs delete mode 100644 src/IconToolbar.hs delete mode 100644 src/KanaConv.hs create mode 100644 src/Wazahs.hi create mode 100644 src/Wazahs.hs create mode 100644 src/Wazahs.hs~ create mode 100644 src/Wazahs.o delete mode 100644 src/getDictionaries.hs delete mode 100644 src/getIcons.hs delete mode 100644 src/make_package.hs 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.hi b/examples/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..b46653b79ae75bd28d8b2c9a46de3452ac0aeb18 GIT binary patch literal 3053 zcmaJ?dsGzX6~9Y|R|MrDKEMcRjizmO++CJe-|WJ|3JVLnywc~e^RYWPJG0Ep3d|P*i5eTz%1P3uwvtwpv{72pTC3I^8c(7&IWe}rqcuj+grpuJJ>~R%GwcE}r~8=Q z@4oN--FrXNN5^=k!eT22fCb|KNt5`!0bm07^RG^hpS}F{=y$gr894X;^tsLEmmc5q z)adOGCto#fy8ZK8Ti<(SuE?58=kO>Q65oAF&vAK zghD8Sdyrr7X(;#%6s&@Rd!b-86s&=q`yl_bQ1m${`aI;{56NaoVIhAlEVIB0D=;=- zitWJQrv#W%V9J0g2c`m;F97pJV7>&*mx1{TFkc1cYrs?j;{e79OcgNIkm7=r8c3;y zR5zrqgS0wGtA{iXq%}ZVBcypDy$Q0KAXg>wvrmAn)st_YGL` zO<4Xd8W~1e_-!cs4is@v)ColaJ!l?Flhl|Dz>ueR{`=C!gL^0C(F;>AY}xt5=4TKr zV7i`t#}y?!)8n+upw(y8kcrqMraxwiGA)0f9gU`jgn`Uk%}y?^A_`A7c#gA)@+kG z=Fx2vgOj^W8=pRV^S4(|pKsTV97_IRVBiYMU|*m!>JDE?e}l29+wTsZ-}N)$`TY~; z9y<8oiz{bXmni=#ecXT~-8Ox6Uk4`42@>PMM@k#l&xO=XPEoj+*}|5vcGkjlaw=Ka zDM*|`Y2|DMYsu}5X++f&K?)+tYNc|k0>Q zdSapa92C;f6H!!DEJY7imgh9iY`COmsX-RMW|y_M&QWSBwmI!3B^_?T(bL@TtXRYo z5>ZJHy0N1HYc?+^B%sL{9CcjE+OkPsfJ8JwmZ%S_g|%mO2_lJbT1Z#2v9>jH2zruc zJLhh6db`&(#;gu0T-3CTyV9DZ?}^=E~k0RrJQXni@!zv$n0QP4-w? zTUIMXm7_|4P#A1%sd-%mX zWu3j!-rri1*#TC_az91ElVTeh{z#2nCp5XiWwT|GkhRFQxn28d29rHFUAZd zwM$mQ2FfKAl#Hk(^r5vfn$G=ENff#eA#*@hXi7E;x!Kk$HWS6`3AK>o%8nYrqjog* zOZKQFD?CvMkJ59R2X!j2OKSOmqG^`shG0`&liXC-)*lF4gw-4Lo}l>C6s=}=PnV;9 zy~kJS>Zy=Dn%_~`Q_eM5X2du#C@X>%3e%1$$Asvz=^sKx1aRp z7nE(0I^{mXFP}?uMO7R&))AF>k)$V-4LygxIO0y0>Rbnoxli97s3eF8?i`oCkldT? zM5Gm2WIeLP@vP79Sw5fQr!B@-D~hb7*VH;$mnd^u8vWz3!B5O>K^Z+CEM6C|Qq`EgyuOVJW+Lm6vLuYv>> zi>edyb>%y_ULit^GGZVeE|Sno5Pf9UShj9tu9z`%KGG8@7!8#L()?d|mMuR8j$SHEFYD7$N#ukn5 zc>}u!S!#%iVjO)VSaoTQ*$Sq)#96GfeK z?|jF`L^aP`ABh^~$8%>fPrCS7e=X~a;U4ZY#(}0k7mHcy+`=2}Z|o35VrHKtA~W)x zq55zT=>=)zJAd`)6K>3gOBQ)5mg-fA80AU2FQ(!}g`KZ21=`GNx+tic3-5n5eU+wo Ja5_Z-{{yhI7e4?1 literal 0 HcmV?d00001 diff --git a/examples/Main.hs b/examples/Main.hs index 7146c80..8a92753 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -1,7 +1,8 @@ -import KanaConv (convertHalfToFull) +module Main where + +import Wazahs (listFiles) main :: IO () main = do - let input = "おいそこのｷﾐ｡あっはいはいはいは～い｡" - let output = convertHalfToFull input - putStrLn output + files <- listFiles "/mnt/Data/Japanese_Resources/Dictionaries/Own_Collection/" + mapM_ putStrLn files diff --git a/examples/Main.o b/examples/Main.o new file mode 100644 index 0000000000000000000000000000000000000000..5123f7623870172b0ab0d542ac2c3187cb149167 GIT binary patch literal 4424 zcmeH~U1%It6vuCpR-?8ytzQ)>u2dAPZrX^_s@P5Q(cO|wHHjD^Wjeb%*{tr)3^TJP zSp|hqY=lAtAAGE$FQtegLQ&8>q~_5)=0QZCtWaTn%YzWlf99Oc&A1bb&mNdP=lt?$Z@@Xbu+p8qupAuO8fj=Fw>tRf26}Us$jB}Juzk?Y!@1Q97b#^AxuAlj-DF_C zyXb<*H1mti@6iq`*Xj>zZ(sL1<~_DksZZ;rMoEdRV;s`Iu;$raUk}IHJRH`EK1h6> zPVO|Gb`yr$-h?Q5l==VPTUi0xJE8Q}?4Wnh49wm$rfb@kZy95j@6^4b<@XL&ib2J( zO|L?Yv$M7_;8d$t$a+=Ytk|lCA9XrAkUEj>OCOK+Uy3qgKb{_aMRlrPnQZR@8QvE+y5+`EA<)wW4wV$?v2-JUnrEkU%@0P2hzDUQgf)3H<#8emQ}Ep1^-h z;D09YL$pBc=9@|2pAtVntJ)nctTHGs=2W4Y?Y{KX>D)zLa$}`1A&GjlZ zgLZ$TGB6%^6}xQIZPzTm!L7!OQLH+C-LurIW}{)w_(rwj2g8-B<+pl}x9*mVY0s=# zQEnj9HEd(r^aEvEvjhFZ;rNA_1Xnk5EtvHDj?epnRclmoXAQR=P+cQ-Yp~EEEcg^$ z8>Q(yJ>MmAl|n-g90-lduv0CWg=**~_EdgqbVuKs>E;{tmJ3hCC5cLGfoQ7ng366@ zgI8gzYr=7}rd_I9p5fJP96VaVQv(17PNFEK4rErbyEQTI(jA!aMrp~%jiSSmVWLJU z@bXTnPV?R|T6`op+DY;yLEA~;)cI>Ol0&@F?jqgIHq_&6<2=$&wI?;MpI)->ksp`j zf0O-j)*_ei_n2c`Tp}N`0ft9G&VY}ZBggG*L;b`y_+GZ5eq|e6zBzz?)3|(70o~NN zj0v=hpGTQjmHi%J9-mhq^Z2}8U>>h$Q1icsb3=`29Al>dNhV^vKf)?tE_GgI{sHrN zojA83@j99azJF322#)I|Zf95v4?iM_;e87Mmz-!z9Jsy@C(%g)uJ5<= zfF$7h{&YhcaeZEM8rS#3yD^^O_L9aAunqNv#`XNyG_K#@WsU3mVNK%?unpDJIKEj# zHrT*?ah^OU9RMUyy1%@~#s6gJMQg74Kg0~`pvJL2@|PY2?b_hh&B48MU^b%7}k#D>4CvgCgWVG=yMtuBZ%;Mu8j{_tliItcP3i%hdA2pKVAyudH9x8`U0EEJse?czV;!;=23ZIgKX-}DS6umAu6 literal 0 HcmV?d00001 diff --git a/src/FileUtils.hs b/src/FileUtils.hs deleted file mode 100644 index f21155f..0000000 --- a/src/FileUtils.hs +++ /dev/null @@ -1,180 +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, isPrefixOf, nub) -import System.IO -import qualified Data.Map as Map -import Control.Concurrent.Async (mapConcurrently) -import Control.Concurrent -import Control.Monad -import Data.Char (isSpace) - --- 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 - - - --- A simple trim function to remove leading/trailing whitespace -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - --- Process lines to produce a list of (directory, [file paths]) tuples. --- It ignores lines until the first "Directory:" is found (and discards it), --- then uses subsequent "Directory:" lines to start new groups. -processLines :: [String] -> [(String, [String])] -processLines = reverse . go False [] - where - -- The Bool flag indicates whether we've encountered the first "Directory:" line. - go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] - go _ acc [] = acc - -- Before the first "Directory:" has been seen: - go False acc (line:rest) - | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. - | otherwise = go False acc rest - -- After the first "Directory:" has been skipped, but before starting any group: - go True [] (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True [(dir, [])] rest - | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. - -- When a group has been started: - go True ((currentDir, files):xs) (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True ((dir, []):(currentDir, files):xs) rest - | otherwise = - go True ((currentDir, files ++ [trim line]) : xs) rest - - -{- -this should be used that way: - - result <- getData "output.txt" - let finalresult = processLines result -- that way we maintain purity --} - -getData :: FilePath -> IO [String] -getData f = do - content <- readFile f - return (lines content) - - - - - - --- 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/IconToolbar.hs b/src/IconToolbar.hs deleted file mode 100644 index d0a2a67..0000000 --- a/src/IconToolbar.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-} --- Copyright © 2025 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, dropExtension, takeExtension) -import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find) -import System.IO -import qualified Data.Map as Map -import Control.Concurrent.Async (mapConcurrently) -import Control.Concurrent -import Control.Monad -import Data.Char (isSpace) -import Data.Maybe (mapMaybe, maybeToList) - - -import qualified GI.Gtk as Gtk -import GI.Gtk (Grid(..), Image(..), Orientable(..)) -import GI.Gio -import Control.Monad (void) -import qualified Data.Text as T - - -{-# LANGUAGE OverloadedStrings #-} - -import qualified GI.Gtk as Gtk -import GI.Gtk (AttrOp((:=))) -import Data.Text (Text) -import qualified Data.Text as T - -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 - ---- - -type FileList = [(String, [String])] -- (Directory, Files) - -extractIcons :: FileList -> [String] -- List of icon paths -extractIcons = concatMap processGroup - where - processGroup (_, files) = maybeToList (findIcon files) - -findIcon :: [String] -> Maybe String -findIcon files = do - mdxFile <- find isMdxFile files - let baseName = dropExtension mdxFile - find (isIconFile baseName) files - where - isMdxFile file = takeExtension file == ".mdx" - isIconFile base file = - dropExtension file == base && - takeExtension file `elem` imageExtensions - -imageExtensions :: [String] -imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"] - - - --- 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 - - - --- A simple trim function to remove leading/trailing whitespace -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - --- Process lines to produce a list of (directory, [file paths]) tuples. --- It ignores lines until the first "Directory:" is found (and discards it), --- then uses subsequent "Directory:" lines to start new groups. -processLines :: [String] -> [(String, [String])] -processLines = reverse . go False [] - where - -- The Bool flag indicates whether we've encountered the first "Directory:" line. - go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] - go _ acc [] = acc - -- Before the first "Directory:" has been seen: - go False acc (line:rest) - | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. - | otherwise = go False acc rest - -- After the first "Directory:" has been skipped, but before starting any group: - go True [] (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True [(dir, [])] rest - | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. - -- When a group has been started: - go True ((currentDir, files):xs) (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True ((dir, []):(currentDir, files):xs) rest - | otherwise = - go True ((currentDir, files ++ [trim line]) : xs) rest - - -{- -this should be used that way: - - result <- getData "output.txt" - let finalresult = processLines result -- that way we maintain purity --} - -getData :: FilePath -> IO [String] -getData f = do - content <- readFile f - return (lines content) - - - -main :: IO () -main = do - - --- Function that builds the cache -{- 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 - - - putStrLn "Starting to write results..." - - -- 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 - - - putStrLn "Finished." --} - -- Get raw data through IO - rawData <- getData "output.txt" - - -- Pure transformations - let processed = processLines rawData - let icons = extractIcons processed - - -- Output results - mapM_ putStrLn icons - - app <- Gtk.applicationNew (Just "com.example.DictionaryIcons") [] - - void $ Gtk.on app #activate $ do - window <- Gtk.applicationWindowNew app - Gtk.windowSetTitle window (Just "Dictionary Toolbar") -- Fixed line - Gtk.windowSetDefaultSize window 800 100 - - -- Rest of the code remains the same - - mainBox <- Gtk.boxNew Gtk.OrientationVertical 0 - toolbar <- createIconToolbar icons - - Gtk.boxAppend mainBox toolbar - Gtk.windowSetChild window (Just mainBox) - Gtk.widgetShow window - - _ <- applicationRun app Nothing - return () - 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/Wazahs.hi b/src/Wazahs.hi new file mode 100644 index 0000000000000000000000000000000000000000..a45f4b8282801c02f09b4a4bea4e8f5d579a39f5 GIT binary patch literal 3375 zcmaJ@c~lhl9sjN)R|Gl4D40mn5>4CeWLXZOH@mQaT#L&g>5&e*KXwOaXO@{+Vfo7# z4W8AeYNJm|j6O9_6JykBs}el=s5S9?G322{Q;#;LDx_*r(SCn3>;jtCw{Lgn_xaxE zZw&WNxW?v~%-H}C!vZin@Y@bx0Jytg*TRo?Y+iQJux;nA!M)q|f9g7Mrhik^% zHY`5$r(0j_*>L{%hQ5w-4;Q?-{Qf6~V~4x;yf=U4()SFlogXh+x^2rk3;FJ` z10+R<}`4DDFr(Dba%^<|C~G9v3?ANJp;Gze01r9_DiX2+P4fYS$TZ# zM^t$@zkTtI`NekZ;Rb~^Z4qHw$m&2QT8}-pljghrGIo^?=$S% zyW*>r_j)dO8E7xVf3Ke1zu>iHyRRC$)-GASZ|lYb&4>a+!($>~O!xVJcAnb#VEskI z`ZKF;-2VL7s<$;k#u)Z+-n_3PwTT#5`{BcN9Vb`0PTlxy@cQo0PX3#!21a2Z?92Jc zg(6|7(Gb=@Z{Agufw0}d2MTK+DgjIjbPe47*McuLxAX5G=<8kB`TB=bH3~4RDSaLN zX~#K08HxV*u*OVdKaBNqyck}?wQwFKhLdG3U^KCrYzAu@TgNG6d>t=xGR3ml9M&|U zE}#-cm3h&PP+A)0OLa=3%g?LEG&Y^hG-g|PUzxY8&TVxRWtEc(M^$6MQ<8v8Dq144 zf`VCSA&qr$DreM9Qngeei(jKHt*O|OWllF+Gcq%4i+D@ptQKodtcwtzLK@Lb1}aF4 zckwcDsuDU!4QH|Dc+%`7K9!e5Y9r0WX2jL=0`YOGM-wu$=IJ8v*^5_r`0FlB60@O%7{jvm+_ulX>rS52tvzI)MzSHyLfk z7Qr#Q!C{+`Uf5uD*ljJOKCk6vuOv!FRp#bm_(S~YU?!Vx^ja+?v%Qk3vcghcImc30 zW-hVjM|oAjh~Bd17pWOu<>%7u%)l^B#@wa?MX(3zE6PZowXkMJjZ|u?u9_wjMe@r| zLd#%gvy3xyNX<+WsV!+J%CR*#i!wbV&sLDC_ynw!30Y{Z@(R+#Ibvy6VQz6oZbnOW zR&7S9l^dt1UNoPH#W2UI#Oo6{tPaLHhX_KnN}6>WNRLr@FAW|W0Y8Ztp{UeLvRAKi zCM`;|U*wxn+YB1cOMX${>#;&crzF#m%(Uc2bCWQO$o5iC6-m#nE#OO)+VU1L!!Js* zi^#-<+#{L?Wpc1f3SCZFRZaf6?uz0HsiL^1#pyNi)8=YDLF-RLOfwcW)>}&Elsa;4 zjX6@OT4~8`%;w5WLu{PjmSkS_cxlIEW55~4^vwE3l3(vJS*r5wvkS%iK%Li}^L!pQ zD_e=-vNjBmQ-gm+qM~x5lPFI=!C~iQg*^A|FdLGaHq1~WIXOYIQ6#EF7CC`^MG}dN zLjRvFB>Bv+HY+C((Z$JZflO$WoS32!3x}GPEg(3KymQ!<@wzY;m@VO20u!`jwU$t} zO01Kbi7RO&X7ejJY^=pEx&#sx64vD`+TsWrnWRxIIOYy*d!P_6U~xy7ba*~ zmISs`5;+&^s4Ptyja1SWWAkNMlA{U=t*lLuI5mEyY6qKNq-%twprnw5$3U#_#8FU@i-;<(21ZNUWy$4ts&S)O9e(dP4Zv_D z-lYfYAYR@rOMai8lh6_Cpcg$x6R8aN2wN_@bdRfXq%hZdlB-dd7IS{HszlS^hf1l$ z(L+%=n;+bSF%+0p>A*yBZsl1`^N1=0O|sP56I9v+A+M%BE{pY&)eu=1#$3~@AcSI4 zH6U3Neu8S}eMCTpiy2J zZCIbESwq)HD2K_x*jbE|E`GMMkaYxb4>#-MK*Jwdi(zzR;`R2|cZkk0v`<2w>G2Ms z4je>!LF)02UOn1`hwBX}|LOXI{fCoI zUu)2ok~*p}M-Xt~HTpTct$5;!9kOD>w+TDGO-y|3%-SV|ZyrZo(|Um@+HRsVr9=t5 UqEbO6Dpi$BaY+ayGN=gt2VFFrLI3~& literal 0 HcmV?d00001 diff --git a/src/Wazahs.hs b/src/Wazahs.hs new file mode 100644 index 0000000..6029665 --- /dev/null +++ b/src/Wazahs.hs @@ -0,0 +1,19 @@ +module Wazahs ( + listFiles +) where + +-- imports + +import qualified Data.Conduit.Combinators as CC +import Data.Conduit +import System.Environment (getArgs) +import System.FilePath (takeExtension) +import Conduit + + +-- | 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 diff --git a/src/Wazahs.hs~ b/src/Wazahs.hs~ new file mode 100644 index 0000000..58f4b23 --- /dev/null +++ b/src/Wazahs.hs~ @@ -0,0 +1,19 @@ +module Wazahs ( + +) where + +-- imports + +import qualified Data.Conduit.Combinators as CC +import Data.Conduit +import System.Environment (getArgs) +import System.FilePath (takeExtension) +import Conduit + + +-- | 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 diff --git a/src/Wazahs.o b/src/Wazahs.o new file mode 100644 index 0000000000000000000000000000000000000000..746ce4afab2fef625cf069598fbbb8b5ba856bb7 GIT binary patch literal 8152 zcmeHMYit}>6&@!697>3r@F)B@EfO*LM9-9yFSa*JJM_JF}aa zS;ZcKNM%)Ifk^qmqe4ZpfT|DmM=27j%0m`P<4S-O@e)X=m|wUOLJL&Fph)4InRCX+ zH#<=kDkP*HX?*Yf?m6E%_ndq0?5@8sP#E0Q)~2zvX`j*7M~rIP6T8;?y-~MU+oruI z0pCx({N;gW;mDfzaDL%0?S;l_zVTYVvE041iu3t}tL^#6mx4@wd7v2qje)hJKf&G) zqv66U&DXJW^S+}ut>*UKy*P;E|DAt3t%LI;QgFIu3gQHim8RXPJ=d~B@xN!i1gF>X zU(R*tjcXfgfC0>0c?Z}r2e$8C=UK%%AJ-SI?kzs})QQcScHv=txxaG-HT28S!BJG^ zV&g!ke)-YPW?XA<9dC!m>1G~wKz`ws)u`$6X~!ukMZbWmE6BGdNW7lAXWmC83I>vT*d$LLqk9ILcmH@&e1>IOy3H~x70L{iC` zSC9ln&EuQh@4Vk&8$|M6YGwG{Nw~#E(AiA(8dW{Y|24hwTC|_ljTM2oyNLMh=Iso$ z$N=xZtTR2Q9XCU>>}!r`yP7tX&t;Bed$NZkt1a+10}t-oq2Wnwlh(F`7@zAlWeiiP zvN^HZsIpn(XjJ^28vz)_es9I`-sU?&8ht1Qe=r4qE(QNy3cj3z|0V_B3JYiz=fxEK z*%bVjDR|GO*8ESV;5Sn6yPzbk;(Qo2V84cT(^lq~KRm@L#3iZ=~Rx zVS~4dXJ-n22=E=S8_U3lG8Q*lF-3nC@VjB3zXWxY@>q)g)1(gvZiDt4wULZ>^l zdqVqA=o~v@9Y5A(oh+Qyj|`qI=?BYJ|KO03tGa<#t%P>O5!w@;>H48PMhu~?yMg7o zW+m~%Qxl0h*Se59Iv9mHRW|CiX=BDS9V?C&gEwnN&6qL$AdX%2sgHzqu44Lr;zJ+# zU$5rYRn3-5p;Pm0C(d;gpcREUa6VTyy=3{fQ#@5XHJm7xs_t~%j*GHCv=4^P;Xb=I z>hYA3vnm>b+=;A1a>uaN>$Gaovx_% zumie6r{_Xt%<@Kyy#0!O%Vs zW#E9RkK{(r9vhkO?sJ{}C%U{aeB|uBF+T4HmJ`~8U^R+X_Gs0&=ZwHSXAR5+mh0P9 zH{pH@R*nfiUpJvvwgpGUuD}7yy_F6O-*(RxY(My~N%`=v@4V0srxIE$Q|sgI#>brx zf30;L@yz3qvO?vupxYubr?IjRCgy8kJ!n?o7UZiBKKS4#AEN@x$BOzXcjj#jn5w0> z32zv#ws8aYLCnk!!|A{)R;TNg^;lXGunyZNzewO~0iPQ;WBCNVCGd6BF7O8kzYE%} z)W@cu`uMp?ewxw+{x0fcQ=vZleTc>lYE{4ABwY3TUBb~X&apg89mLmvb8#J*K z2OyXSRH>2P9tD4a@GinJ57=FV2j#HP|8NXNe=CGzgHI>%d`alb{C`8>sJce_PZ7?3 zGcbqpoWS|FH^hHUI5zljo&HX^TKAg*N0(jXcN-Nc$q(t>OSl@(eFFa=@URpJM{|7s zKoh40zs!Rpc=kZ0-QSlv=Zxx?R!M`SO{Lah#zZJOjt5bcD|06>G`vTu3 z@O_jI)c>f!A4|b+q~HTc0HUtz+X9zY_63ty#aE@<9;2#q_ zs{+TXg4fU#xYS=0IO->74}$=~>CUJZ|7jOEcK=599SZ&@!nLeF?*!%)w1F45W$t-a z#molQT%cv6?lgSi*0NK+592Bh&_>I;)xgTaZ>0D80esQavZboySS}bv6SHnTTl1^+}#Xle~(|sC`;_n39#}@B=ROy9B%5}OFnnaB64D{1ZO8i;l zlZ4YXPqWZaAv2U`o?v?(e;hik{4dd=;NR8IKl)&M_TNpI>OUhdeb8ayGV}NlbP(%d zfLgYfcO6c#J-2-VBh#qqev|&k$i7P&L!a&CI|o(RFSnls3|%Q{)_Tdm%FFpfE)?WZ zZ4s}LJ%295IIyH_&-vd9n3{Wlv{ft^$e;N@$HOFk8p3a(t?l>X%O3>(5wSsd-3), takeDirectory) -import qualified System.FilePath as FP -import Filesystem.Path.CurrentOS (FilePath, encodeString, decodeString) -import qualified Filesystem.Path.CurrentOS as FP -import qualified Filesystem as FS -import qualified Data.Text as T - -import Pipes -import Pipes.Safe (runSafeT, MonadSafe) -import Data.DirStream -import Control.Monad.State.Strict -import qualified Data.HashMap.Strict as HM -import qualified Data.Text.IO as TIO -import Data.Maybe (fromMaybe) - -import Control.Monad (when, filterM) -import Data.List (sort) - -type MdxIndex = HM.HashMap String (FilePath, [FilePath]) - - -main :: IO () -main = do - hSetEncoding stdout utf8 - mdxMap <- execStateT (runSafeT $ runEffect pipeline) (HM.empty :: MdxIndex) - - -- print everything - forM_ (HM.toList mdxMap) $ \(mdx, (folder, files)) -> do - TIO.putStrLn $ "MDX: " <> T.pack mdx - TIO.putStrLn $ "Folder: " <> T.pack (encodeString folder) - mapM_ (TIO.putStrLn . (" " <>) . T.pack . encodeString) (sort files) - - TIO.putStrLn "" - -pipeline :: forall m. (MonadSafe m, MonadState MdxIndex m, MonadFail m) => Effect m () -pipeline = - for (every (descendentOf "/mnt/Data/Japanese_Resources/Dictionaries/")) $ \fp -> - when (FP.extension fp == Just "mdx") $ do - let folder = FP.directory fp - allFiles <- liftIO $ FS.listDirectory folder - modify' (HM.insert (encodeString fp) (folder, allFiles)) - - - - diff --git a/src/getIcons.hs b/src/getIcons.hs deleted file mode 100644 index 79fd795..0000000 --- a/src/getIcons.hs +++ /dev/null @@ -1,161 +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, dropExtension, takeExtension) -import Data.List (groupBy, isSuffixOf, isPrefixOf, nub, find) -import System.IO -import qualified Data.Map as Map -import Control.Concurrent.Async (mapConcurrently) -import Control.Concurrent -import Control.Monad -import Data.Char (isSpace) -import Data.Maybe (mapMaybe, maybeToList) - - -type FileList = [(String, [String])] -- (Directory, Files) - -extractIcons :: FileList -> [String] -- List of icon paths -extractIcons = concatMap processGroup - where - processGroup (_, files) = maybeToList (findIcon files) - -findIcon :: [String] -> Maybe String -findIcon files = do - mdxFile <- find isMdxFile files - let baseName = dropExtension mdxFile - find (isIconFile baseName) files - where - isMdxFile file = takeExtension file == ".mdx" - isIconFile base file = - dropExtension file == base && - takeExtension file `elem` imageExtensions - -imageExtensions :: [String] -imageExtensions = [".png", ".jpg", ".jpeg", ".gif", ".bmp", ".svg"] - - - --- 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 - - - --- A simple trim function to remove leading/trailing whitespace -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - --- Process lines to produce a list of (directory, [file paths]) tuples. --- It ignores lines until the first "Directory:" is found (and discards it), --- then uses subsequent "Directory:" lines to start new groups. -processLines :: [String] -> [(String, [String])] -processLines = reverse . go False [] - where - -- The Bool flag indicates whether we've encountered the first "Directory:" line. - go :: Bool -> [(String, [String])] -> [String] -> [(String, [String])] - go _ acc [] = acc - -- Before the first "Directory:" has been seen: - go False acc (line:rest) - | "Directory:" `isPrefixOf` line = go True acc rest -- Skip first occurrence. - | otherwise = go False acc rest - -- After the first "Directory:" has been skipped, but before starting any group: - go True [] (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True [(dir, [])] rest - | otherwise = go True [] rest -- Ignore non-directory lines until the second occurrence. - -- When a group has been started: - go True ((currentDir, files):xs) (line:rest) - | "Directory:" `isPrefixOf` line = - let dir = trim (drop 11 line) - in go True ((dir, []):(currentDir, files):xs) rest - | otherwise = - go True ((currentDir, files ++ [trim line]) : xs) rest - - - -getData :: FilePath -> IO [String] -getData f = do - content <- readFile f - return (lines content) - - - -main :: IO () -main = do - -- Get raw data through IO - rawData <- getData "output.txt" - - -- Pure transformations - let processed = processLines rawData - let icons = extractIcons processed - - -- Output results - mapM_ putStrLn icons - diff --git a/src/make_package.hs b/src/make_package.hs deleted file mode 100644 index 7d063b3..0000000 --- a/src/make_package.hs +++ /dev/null @@ -1,208 +0,0 @@ --- currently not working, needs refactoring. - -import Control.Exception (bracket_) -import qualified Control.Lens as Lens -import Control.Lens.Operators -import Control.Monad (when, unless, filterM) -import Data.Foldable (traverse_) -import qualified System.Directory as Dir -import qualified System.Environment as Env -import System.FilePath ((), takeFileName, takeDirectory) -import qualified System.Info as SysInfo -import System.Process (readProcess, callProcess) - -import Prelude - -interestingLibs :: [String] -interestingLibs = - [ "libGLEW" - , "libGLU" - , "libXcursor" - , "libXi" - , "libXinerama" - , "libXrandr" - , "libXrender" - , "libbsd" - , "libbz2" - , "libcares" - , "libcrypto" - , "libdw" - , "libelf" - , "libgflags" - , "libgmp" - , "libicudata" - , "libicui18n" - , "libicuuc" - , "liblzma" - , "libnghttp2" - , "libnode" - , "librocksdb" - , "libsnappy" - , "libssl" - , "libuv" - ] - -isInteresting :: FilePath -> Bool -isInteresting path = - baseName `elem` interestingLibs - where - -- takeBaseName removes one extension, we remove all: - baseName = takeFileName path & takeWhile (/= '.') - -parseLddOut :: String -> [FilePath] -parseLddOut lddOut = - lines lddOut - >>= parseLine - & filter isInteresting - where - parseLine line = - case words line & dropWhile (/= "=>") of - [] -> [] - "=>":libPath:_ -> [libPath] - _ -> error "unexpected break output" - -otoolMinMacosVersion :: FilePath -> IO Float -otoolMinMacosVersion path = - readProcess "otool" ["-l", path] "" <&> - (^?! Lens.to lines . traverse . - Lens.to words . - Lens.filteredBy (Lens.ix 0 . (Lens.only "minos" <> Lens.only "version")) . - Lens.ix 1 . Lens._Show) - --- Use `otool` to recursively find macOS deps -findDylibs :: FilePath -> IO [FilePath] -findDylibs path = - do - deps <- - readProcess "otool" ["-L", path] "" - <&> lines <&> tail <&> map words <&> (>>= take 1) - <&> filter (/= path) - >>= filterM Dir.doesPathExist - traverse findDylibs deps <&> concat <&> (deps <>) - --- Slightly nicer syntax than using a sum type with case everywhere -isMacOS :: Bool -isMacOS = SysInfo.os == "darwin" - -isWindows :: Bool -isWindows = SysInfo.os == "mingw32" - -isLinux :: Bool -isLinux = SysInfo.os == "linux" - -pkgDir :: FilePath -pkgDir - | isMacOS = "Lamdu.app" - | otherwise = "lamdu" - -toPackageWith :: FilePath -> FilePath -> IO () -toPackageWith srcPath relPath = - do - putStrLn $ "Packaging " ++ srcPath ++ " to " ++ destPath - Dir.createDirectoryIfMissing True (takeDirectory destPath) - callProcess "cp" ["-aLR", srcPath, destPath] - where - destPath = contentsDir relPath - contentsDir - | isMacOS = pkgDir "Contents" - | otherwise = pkgDir - -toPackage :: FilePath -> IO () -toPackage srcPath = toPackageWith srcPath (takeFileName srcPath) - -libToPackage :: FilePath -> IO () -libToPackage srcPath = - toPackageWith srcPath (dir filename) - where - filename = takeFileName srcPath - dir - | isWindows = "." - | isMacOS = "MacOS" - | otherwise = "lib" - -findDeps :: String -> IO [FilePath] -findDeps exec - | isWindows = - [ "libwinpthread-1.dll" - , "libstdc++-6.dll" - , "libgcc_s_seh-1.dll" - , "librocksdb.dll" - , "libbz2-1.dll" - , "liblz4.dll" - , "zlib1.dll" - , "libzstd.dll" - ] <&> ("/mingw64/bin" ) - & pure - | isMacOS = - findDylibs exec - | otherwise = - readProcess "ldd" [exec] "" <&> parseLddOut - -fixDylibPaths :: FilePath -> IO () -fixDylibPaths targetName = - findDylibs target >>= - traverse_ fixDep - where - target = pkgDir "Contents" "MacOS" targetName - fixDep dep = - do - callProcess "chmod" ["+w", target] - callProcess "install_name_tool" - ["-change", dep, "@executable_path/" ++ takeFileName dep, target] - -parseLamduVersion :: String -> String -parseLamduVersion info = - case lines info <&> words of - (["Lamdu", result]:_) -> result - _ -> error "failed parsing version number" - -whichCmd :: String -whichCmd - | isWindows = "where" - | otherwise = "which" - -main :: IO () -main = - do - [lamduExec] <- Env.getArgs - nodePath <- readProcess whichCmd ["node"] "" <&> takeWhile (`notElem` "\r\n") - nodeDeps <- findDeps nodePath - when isMacOS $ - do - unless (null nodeDeps) $ fail "nodejs not statically linked!" - minos <- otoolMinMacosVersion lamduExec - when (minos > 10.9) (fail "Lamdu executable only runs on new macOS versions") - version <- readProcess lamduExec ["--version"] "" <&> parseLamduVersion - lamduDeps <- findDeps lamduExec - let allDeps = nodeDeps <> lamduDeps - bracket_ (Dir.createDirectory pkgDir) (unless isMacOS (Dir.removeDirectoryRecursive pkgDir)) $ - do - toPackageWith lamduExec destPath - toPackageWith "data" dataDir - toPackageWith nodePath (dataDir "bin/node.exe") - traverse_ libToPackage allDeps - when isWindows $ - callProcess "iscc.exe" ["/Flamdu-" ++ version ++ "-win-setup", "tools\\data\\lamdu.iss"] - when isLinux $ - do - toPackage "tools/data/run-lamdu.sh" - callProcess "tar" ["-c", "-z", "-f", "lamdu-" ++ version ++ "-linux.tgz", pkgDir] - when isMacOS $ - do - toPackage "tools/data/Info.plist" - traverse_ fixDylibPaths ("lamdu" : (allDeps <&> takeFileName)) - callProcess "sh" - [ "tools/data/macos_icon.sh" - , "data/Lamdu.png" - , pkgDir "Contents" "Resources" "lamdu.icns" - ] - -- The next steps of signing, notarization, and stapling happen in a seperate script - putStrLn "Done" - where - destPath - | isWindows = "lamdu.exe" - | isMacOS = "MacOS/lamdu" - | otherwise = "bin/lamdu" - dataDir - | isMacOS = "Resources" - | otherwise = "data" From bbe2bf2cef8b5a0c9f8ede83cd1c1526d8bf3299 Mon Sep 17 00:00:00 2001 From: hashirama Date: Fri, 12 Sep 2025 21:38:25 -0400 Subject: [PATCH 12/23] add gitignore --- .gitignore | 12 ++++++++++++ examples/Main.hi | Bin 3053 -> 0 bytes examples/Main.o | Bin 4424 -> 0 bytes src/Wazahs.hi | Bin 3375 -> 0 bytes src/Wazahs.hs~ | 19 ------------------- src/Wazahs.o | Bin 8152 -> 0 bytes 6 files changed, 12 insertions(+), 19 deletions(-) create mode 100644 .gitignore delete mode 100644 examples/Main.hi delete mode 100644 examples/Main.o delete mode 100644 src/Wazahs.hi delete mode 100644 src/Wazahs.hs~ delete mode 100644 src/Wazahs.o 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/examples/Main.hi b/examples/Main.hi deleted file mode 100644 index b46653b79ae75bd28d8b2c9a46de3452ac0aeb18..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3053 zcmaJ?dsGzX6~9Y|R|MrDKEMcRjizmO++CJe-|WJ|3JVLnywc~e^RYWPJG0Ep3d|P*i5eTz%1P3uwvtwpv{72pTC3I^8c(7&IWe}rqcuj+grpuJJ>~R%GwcE}r~8=Q z@4oN--FrXNN5^=k!eT22fCb|KNt5`!0bm07^RG^hpS}F{=y$gr894X;^tsLEmmc5q z)adOGCto#fy8ZK8Ti<(SuE?58=kO>Q65oAF&vAK zghD8Sdyrr7X(;#%6s&@Rd!b-86s&=q`yl_bQ1m${`aI;{56NaoVIhAlEVIB0D=;=- zitWJQrv#W%V9J0g2c`m;F97pJV7>&*mx1{TFkc1cYrs?j;{e79OcgNIkm7=r8c3;y zR5zrqgS0wGtA{iXq%}ZVBcypDy$Q0KAXg>wvrmAn)st_YGL` zO<4Xd8W~1e_-!cs4is@v)ColaJ!l?Flhl|Dz>ueR{`=C!gL^0C(F;>AY}xt5=4TKr zV7i`t#}y?!)8n+upw(y8kcrqMraxwiGA)0f9gU`jgn`Uk%}y?^A_`A7c#gA)@+kG z=Fx2vgOj^W8=pRV^S4(|pKsTV97_IRVBiYMU|*m!>JDE?e}l29+wTsZ-}N)$`TY~; z9y<8oiz{bXmni=#ecXT~-8Ox6Uk4`42@>PMM@k#l&xO=XPEoj+*}|5vcGkjlaw=Ka zDM*|`Y2|DMYsu}5X++f&K?)+tYNc|k0>Q zdSapa92C;f6H!!DEJY7imgh9iY`COmsX-RMW|y_M&QWSBwmI!3B^_?T(bL@TtXRYo z5>ZJHy0N1HYc?+^B%sL{9CcjE+OkPsfJ8JwmZ%S_g|%mO2_lJbT1Z#2v9>jH2zruc zJLhh6db`&(#;gu0T-3CTyV9DZ?}^=E~k0RrJQXni@!zv$n0QP4-w? zTUIMXm7_|4P#A1%sd-%mX zWu3j!-rri1*#TC_az91ElVTeh{z#2nCp5XiWwT|GkhRFQxn28d29rHFUAZd zwM$mQ2FfKAl#Hk(^r5vfn$G=ENff#eA#*@hXi7E;x!Kk$HWS6`3AK>o%8nYrqjog* zOZKQFD?CvMkJ59R2X!j2OKSOmqG^`shG0`&liXC-)*lF4gw-4Lo}l>C6s=}=PnV;9 zy~kJS>Zy=Dn%_~`Q_eM5X2du#C@X>%3e%1$$Asvz=^sKx1aRp z7nE(0I^{mXFP}?uMO7R&))AF>k)$V-4LygxIO0y0>Rbnoxli97s3eF8?i`oCkldT? zM5Gm2WIeLP@vP79Sw5fQr!B@-D~hb7*VH;$mnd^u8vWz3!B5O>K^Z+CEM6C|Qq`EgyuOVJW+Lm6vLuYv>> zi>edyb>%y_ULit^GGZVeE|Sno5Pf9UShj9tu9z`%KGG8@7!8#L()?d|mMuR8j$SHEFYD7$N#ukn5 zc>}u!S!#%iVjO)VSaoTQ*$Sq)#96GfeK z?|jF`L^aP`ABh^~$8%>fPrCS7e=X~a;U4ZY#(}0k7mHcy+`=2}Z|o35VrHKtA~W)x zq55zT=>=)zJAd`)6K>3gOBQ)5mg-fA80AU2FQ(!}g`KZ21=`GNx+tic3-5n5eU+wo Ja5_Z-{{yhI7e4?1 diff --git a/examples/Main.o b/examples/Main.o deleted file mode 100644 index 5123f7623870172b0ab0d542ac2c3187cb149167..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4424 zcmeH~U1%It6vuCpR-?8ytzQ)>u2dAPZrX^_s@P5Q(cO|wHHjD^Wjeb%*{tr)3^TJP zSp|hqY=lAtAAGE$FQtegLQ&8>q~_5)=0QZCtWaTn%YzWlf99Oc&A1bb&mNdP=lt?$Z@@Xbu+p8qupAuO8fj=Fw>tRf26}Us$jB}Juzk?Y!@1Q97b#^AxuAlj-DF_C zyXb<*H1mti@6iq`*Xj>zZ(sL1<~_DksZZ;rMoEdRV;s`Iu;$raUk}IHJRH`EK1h6> zPVO|Gb`yr$-h?Q5l==VPTUi0xJE8Q}?4Wnh49wm$rfb@kZy95j@6^4b<@XL&ib2J( zO|L?Yv$M7_;8d$t$a+=Ytk|lCA9XrAkUEj>OCOK+Uy3qgKb{_aMRlrPnQZR@8QvE+y5+`EA<)wW4wV$?v2-JUnrEkU%@0P2hzDUQgf)3H<#8emQ}Ep1^-h z;D09YL$pBc=9@|2pAtVntJ)nctTHGs=2W4Y?Y{KX>D)zLa$}`1A&GjlZ zgLZ$TGB6%^6}xQIZPzTm!L7!OQLH+C-LurIW}{)w_(rwj2g8-B<+pl}x9*mVY0s=# zQEnj9HEd(r^aEvEvjhFZ;rNA_1Xnk5EtvHDj?epnRclmoXAQR=P+cQ-Yp~EEEcg^$ z8>Q(yJ>MmAl|n-g90-lduv0CWg=**~_EdgqbVuKs>E;{tmJ3hCC5cLGfoQ7ng366@ zgI8gzYr=7}rd_I9p5fJP96VaVQv(17PNFEK4rErbyEQTI(jA!aMrp~%jiSSmVWLJU z@bXTnPV?R|T6`op+DY;yLEA~;)cI>Ol0&@F?jqgIHq_&6<2=$&wI?;MpI)->ksp`j zf0O-j)*_ei_n2c`Tp}N`0ft9G&VY}ZBggG*L;b`y_+GZ5eq|e6zBzz?)3|(70o~NN zj0v=hpGTQjmHi%J9-mhq^Z2}8U>>h$Q1icsb3=`29Al>dNhV^vKf)?tE_GgI{sHrN zojA83@j99azJF322#)I|Zf95v4?iM_;e87Mmz-!z9Jsy@C(%g)uJ5<= zfF$7h{&YhcaeZEM8rS#3yD^^O_L9aAunqNv#`XNyG_K#@WsU3mVNK%?unpDJIKEj# zHrT*?ah^OU9RMUyy1%@~#s6gJMQg74Kg0~`pvJL2@|PY2?b_hh&B48MU^b%7}k#D>4CvgCgWVG=yMtuBZ%;Mu8j{_tliItcP3i%hdA2pKVAyudH9x8`U0EEJse?czV;!;=23ZIgKX-}DS6umAu6 diff --git a/src/Wazahs.hi b/src/Wazahs.hi deleted file mode 100644 index a45f4b8282801c02f09b4a4bea4e8f5d579a39f5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3375 zcmaJ@c~lhl9sjN)R|Gl4D40mn5>4CeWLXZOH@mQaT#L&g>5&e*KXwOaXO@{+Vfo7# z4W8AeYNJm|j6O9_6JykBs}el=s5S9?G322{Q;#;LDx_*r(SCn3>;jtCw{Lgn_xaxE zZw&WNxW?v~%-H}C!vZin@Y@bx0Jytg*TRo?Y+iQJux;nA!M)q|f9g7Mrhik^% zHY`5$r(0j_*>L{%hQ5w-4;Q?-{Qf6~V~4x;yf=U4()SFlogXh+x^2rk3;FJ` z10+R<}`4DDFr(Dba%^<|C~G9v3?ANJp;Gze01r9_DiX2+P4fYS$TZ# zM^t$@zkTtI`NekZ;Rb~^Z4qHw$m&2QT8}-pljghrGIo^?=$S% zyW*>r_j)dO8E7xVf3Ke1zu>iHyRRC$)-GASZ|lYb&4>a+!($>~O!xVJcAnb#VEskI z`ZKF;-2VL7s<$;k#u)Z+-n_3PwTT#5`{BcN9Vb`0PTlxy@cQo0PX3#!21a2Z?92Jc zg(6|7(Gb=@Z{Agufw0}d2MTK+DgjIjbPe47*McuLxAX5G=<8kB`TB=bH3~4RDSaLN zX~#K08HxV*u*OVdKaBNqyck}?wQwFKhLdG3U^KCrYzAu@TgNG6d>t=xGR3ml9M&|U zE}#-cm3h&PP+A)0OLa=3%g?LEG&Y^hG-g|PUzxY8&TVxRWtEc(M^$6MQ<8v8Dq144 zf`VCSA&qr$DreM9Qngeei(jKHt*O|OWllF+Gcq%4i+D@ptQKodtcwtzLK@Lb1}aF4 zckwcDsuDU!4QH|Dc+%`7K9!e5Y9r0WX2jL=0`YOGM-wu$=IJ8v*^5_r`0FlB60@O%7{jvm+_ulX>rS52tvzI)MzSHyLfk z7Qr#Q!C{+`Uf5uD*ljJOKCk6vuOv!FRp#bm_(S~YU?!Vx^ja+?v%Qk3vcghcImc30 zW-hVjM|oAjh~Bd17pWOu<>%7u%)l^B#@wa?MX(3zE6PZowXkMJjZ|u?u9_wjMe@r| zLd#%gvy3xyNX<+WsV!+J%CR*#i!wbV&sLDC_ynw!30Y{Z@(R+#Ibvy6VQz6oZbnOW zR&7S9l^dt1UNoPH#W2UI#Oo6{tPaLHhX_KnN}6>WNRLr@FAW|W0Y8Ztp{UeLvRAKi zCM`;|U*wxn+YB1cOMX${>#;&crzF#m%(Uc2bCWQO$o5iC6-m#nE#OO)+VU1L!!Js* zi^#-<+#{L?Wpc1f3SCZFRZaf6?uz0HsiL^1#pyNi)8=YDLF-RLOfwcW)>}&Elsa;4 zjX6@OT4~8`%;w5WLu{PjmSkS_cxlIEW55~4^vwE3l3(vJS*r5wvkS%iK%Li}^L!pQ zD_e=-vNjBmQ-gm+qM~x5lPFI=!C~iQg*^A|FdLGaHq1~WIXOYIQ6#EF7CC`^MG}dN zLjRvFB>Bv+HY+C((Z$JZflO$WoS32!3x}GPEg(3KymQ!<@wzY;m@VO20u!`jwU$t} zO01Kbi7RO&X7ejJY^=pEx&#sx64vD`+TsWrnWRxIIOYy*d!P_6U~xy7ba*~ zmISs`5;+&^s4Ptyja1SWWAkNMlA{U=t*lLuI5mEyY6qKNq-%twprnw5$3U#_#8FU@i-;<(21ZNUWy$4ts&S)O9e(dP4Zv_D z-lYfYAYR@rOMai8lh6_Cpcg$x6R8aN2wN_@bdRfXq%hZdlB-dd7IS{HszlS^hf1l$ z(L+%=n;+bSF%+0p>A*yBZsl1`^N1=0O|sP56I9v+A+M%BE{pY&)eu=1#$3~@AcSI4 zH6U3Neu8S}eMCTpiy2J zZCIbESwq)HD2K_x*jbE|E`GMMkaYxb4>#-MK*Jwdi(zzR;`R2|cZkk0v`<2w>G2Ms z4je>!LF)02UOn1`hwBX}|LOXI{fCoI zUu)2ok~*p}M-Xt~HTpTct$5;!9kOD>w+TDGO-y|3%-SV|ZyrZo(|Um@+HRsVr9=t5 UqEbO6Dpi$BaY+ayGN=gt2VFFrLI3~& diff --git a/src/Wazahs.hs~ b/src/Wazahs.hs~ deleted file mode 100644 index 58f4b23..0000000 --- a/src/Wazahs.hs~ +++ /dev/null @@ -1,19 +0,0 @@ -module Wazahs ( - -) where - --- imports - -import qualified Data.Conduit.Combinators as CC -import Data.Conduit -import System.Environment (getArgs) -import System.FilePath (takeExtension) -import Conduit - - --- | 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 diff --git a/src/Wazahs.o b/src/Wazahs.o deleted file mode 100644 index 746ce4afab2fef625cf069598fbbb8b5ba856bb7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8152 zcmeHMYit}>6&@!697>3r@F)B@EfO*LM9-9yFSa*JJM_JF}aa zS;ZcKNM%)Ifk^qmqe4ZpfT|DmM=27j%0m`P<4S-O@e)X=m|wUOLJL&Fph)4InRCX+ zH#<=kDkP*HX?*Yf?m6E%_ndq0?5@8sP#E0Q)~2zvX`j*7M~rIP6T8;?y-~MU+oruI z0pCx({N;gW;mDfzaDL%0?S;l_zVTYVvE041iu3t}tL^#6mx4@wd7v2qje)hJKf&G) zqv66U&DXJW^S+}ut>*UKy*P;E|DAt3t%LI;QgFIu3gQHim8RXPJ=d~B@xN!i1gF>X zU(R*tjcXfgfC0>0c?Z}r2e$8C=UK%%AJ-SI?kzs})QQcScHv=txxaG-HT28S!BJG^ zV&g!ke)-YPW?XA<9dC!m>1G~wKz`ws)u`$6X~!ukMZbWmE6BGdNW7lAXWmC83I>vT*d$LLqk9ILcmH@&e1>IOy3H~x70L{iC` zSC9ln&EuQh@4Vk&8$|M6YGwG{Nw~#E(AiA(8dW{Y|24hwTC|_ljTM2oyNLMh=Iso$ z$N=xZtTR2Q9XCU>>}!r`yP7tX&t;Bed$NZkt1a+10}t-oq2Wnwlh(F`7@zAlWeiiP zvN^HZsIpn(XjJ^28vz)_es9I`-sU?&8ht1Qe=r4qE(QNy3cj3z|0V_B3JYiz=fxEK z*%bVjDR|GO*8ESV;5Sn6yPzbk;(Qo2V84cT(^lq~KRm@L#3iZ=~Rx zVS~4dXJ-n22=E=S8_U3lG8Q*lF-3nC@VjB3zXWxY@>q)g)1(gvZiDt4wULZ>^l zdqVqA=o~v@9Y5A(oh+Qyj|`qI=?BYJ|KO03tGa<#t%P>O5!w@;>H48PMhu~?yMg7o zW+m~%Qxl0h*Se59Iv9mHRW|CiX=BDS9V?C&gEwnN&6qL$AdX%2sgHzqu44Lr;zJ+# zU$5rYRn3-5p;Pm0C(d;gpcREUa6VTyy=3{fQ#@5XHJm7xs_t~%j*GHCv=4^P;Xb=I z>hYA3vnm>b+=;A1a>uaN>$Gaovx_% zumie6r{_Xt%<@Kyy#0!O%Vs zW#E9RkK{(r9vhkO?sJ{}C%U{aeB|uBF+T4HmJ`~8U^R+X_Gs0&=ZwHSXAR5+mh0P9 zH{pH@R*nfiUpJvvwgpGUuD}7yy_F6O-*(RxY(My~N%`=v@4V0srxIE$Q|sgI#>brx zf30;L@yz3qvO?vupxYubr?IjRCgy8kJ!n?o7UZiBKKS4#AEN@x$BOzXcjj#jn5w0> z32zv#ws8aYLCnk!!|A{)R;TNg^;lXGunyZNzewO~0iPQ;WBCNVCGd6BF7O8kzYE%} z)W@cu`uMp?ewxw+{x0fcQ=vZleTc>lYE{4ABwY3TUBb~X&apg89mLmvb8#J*K z2OyXSRH>2P9tD4a@GinJ57=FV2j#HP|8NXNe=CGzgHI>%d`alb{C`8>sJce_PZ7?3 zGcbqpoWS|FH^hHUI5zljo&HX^TKAg*N0(jXcN-Nc$q(t>OSl@(eFFa=@URpJM{|7s zKoh40zs!Rpc=kZ0-QSlv=Zxx?R!M`SO{Lah#zZJOjt5bcD|06>G`vTu3 z@O_jI)c>f!A4|b+q~HTc0HUtz+X9zY_63ty#aE@<9;2#q_ zs{+TXg4fU#xYS=0IO->74}$=~>CUJZ|7jOEcK=599SZ&@!nLeF?*!%)w1F45W$t-a z#molQT%cv6?lgSi*0NK+592Bh&_>I;)xgTaZ>0D80esQavZboySS}bv6SHnTTl1^+}#Xle~(|sC`;_n39#}@B=ROy9B%5}OFnnaB64D{1ZO8i;l zlZ4YXPqWZaAv2U`o?v?(e;hik{4dd=;NR8IKl)&M_TNpI>OUhdeb8ayGV}NlbP(%d zfLgYfcO6c#J-2-VBh#qqev|&k$i7P&L!a&CI|o(RFSnls3|%Q{)_Tdm%FFpfE)?WZ zZ4s}LJ%295IIyH_&-vd9n3{Wlv{ft^$e;N@$HOFk8p3a(t?l>X%O3>(5wSsd-3 Date: Fri, 12 Sep 2025 22:58:08 -0400 Subject: [PATCH 13/23] add folder selection helper --- examples/Main.hs | 39 +++++++++++++++++++++++++++++++++++---- src/Wazahs.hs | 22 +++++++++++++++++++++- 2 files changed, 56 insertions(+), 5 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 8a92753..dbc11e9 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -1,8 +1,39 @@ -module Main where +-- 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.Gio hiding (Application) +import Wazahs +import Control.Concurrent + -import Wazahs (listFiles) main :: IO () main = do - files <- listFiles "/mnt/Data/Japanese_Resources/Dictionaries/Own_Collection/" - mapM_ putStrLn files + app <- new Application [] + onApplicationActivate app $ do + + w <- new GI.Gtk.ApplicationWindow [#application := app,#title := "Wazajisho"] + fd <- GTK.fileDialogNew + GTK.fileDialogSetTitle fd "Select folder..." + GTK.fileDialogSetModal fd True + GTK.fileDialogSetAcceptLabel fd (Just "Select") + + selectFolder fd w $ maybe + (putStrLn "No valid directory selected") + (\dir -> do + files <- listFiles dir + putStrLn "Selected directory:" + mapM_ putStrLn files) + + + + applicationRun app Nothing + threadDelay 30000000000 diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 6029665..9742d98 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -1,10 +1,20 @@ module Wazahs ( - listFiles + listFiles, + selectFolder ) where -- imports import qualified Data.Conduit.Combinators as CC +import GI.Gtk +import GI.Gio hiding (Application) +import qualified GI.Gtk as GTK +import Control.Monad (when, void, mzero, guard) +import Data.Foldable (for_) +import System.Directory (doesDirectoryExist, listDirectory) +import System.FilePath (()) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Conduit import System.Environment (getArgs) import System.FilePath (takeExtension) @@ -17,3 +27,13 @@ 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 From 170bc26cd4e88019f525fd0e46ed33de6e4dc7fc Mon Sep 17 00:00:00 2001 From: hashirama Date: Tue, 16 Sep 2025 20:15:55 -0400 Subject: [PATCH 14/23] start working on a better handler for the dictionaries --- examples/Main.hs | 28 ++++++++++++++++++++-------- src/Wazahs.hs | 3 +++ 2 files changed, 23 insertions(+), 8 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index dbc11e9..e18aac4 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -12,9 +12,9 @@ import qualified GI.Gtk as GTK import GI.Gio hiding (Application) import Wazahs import Control.Concurrent +import Control.Concurrent.STM - - +-- Wrapper to make FileDialog synchronous main :: IO () main = do app <- new Application [] @@ -26,12 +26,24 @@ main = do GTK.fileDialogSetModal fd True GTK.fileDialogSetAcceptLabel fd (Just "Select") - selectFolder fd w $ maybe - (putStrLn "No valid directory selected") - (\dir -> do - files <- listFiles dir - putStrLn "Selected directory:" - mapM_ putStrLn files) + filesVar <- newTVarIO [] + + selectFolder fd w $ \maybeDir -> do + case maybeDir of + Nothing -> putStrLn "No valid directory selected" + Just dir -> do + fs <- listFiles dir + atomically $ writeTVar filesVar fs + putStrLn "Selected directory:" + mapM_ putStrLn fs + +-- Later, anywhere else in your program: + files <- readTVarIO filesVar + + + mapM_ putStrLn files + + diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 9742d98..1b3398f 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -37,3 +37,6 @@ selectFolder fd w k = p <- MaybeT $ fileGetPath f p <$ (liftIO (doesDirectoryExist p) >>= guard) k mbPath + +-- compose the two here: [TODO] + From 6f9fa07facff1388f72a36bf94d9e94cd2503892 Mon Sep 17 00:00:00 2001 From: hashirama Date: Tue, 16 Sep 2025 22:07:50 -0400 Subject: [PATCH 15/23] high level path handler --- examples/Main.hs | 38 +++++++++------------------- src/Wazahs.hs | 64 ++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 70 insertions(+), 32 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index e18aac4..36ac93e 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -5,47 +5,31 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} - - import GI.Gtk import qualified GI.Gtk as GTK import GI.Gio hiding (Application) import Wazahs import Control.Concurrent -import Control.Concurrent.STM +import System.FilePath (()) +import System.IO (writeFile) + + --- Wrapper to make FileDialog synchronous main :: IO () main = do app <- new Application [] + onApplicationActivate app $ do - - w <- new GI.Gtk.ApplicationWindow [#application := app,#title := "Wazajisho"] + w <- new GI.Gtk.ApplicationWindow [#application := app, #title := "Wazajisho"] fd <- GTK.fileDialogNew - GTK.fileDialogSetTitle fd "Select folder..." - GTK.fileDialogSetModal fd True - GTK.fileDialogSetAcceptLabel fd (Just "Select") - - filesVar <- newTVarIO [] - selectFolder fd w $ \maybeDir -> do - case maybeDir of - Nothing -> putStrLn "No valid directory selected" - Just dir -> do - fs <- listFiles dir - atomically $ writeTVar filesVar fs - putStrLn "Selected directory:" - mapM_ putStrLn fs + home <- getHomeDirectory + let cfg = home ".local" "share" "wazajisho" "config" --- Later, anywhere else in your program: - files <- readTVarIO filesVar + getFolderAsync fd w cfg $ \mPath -> case mPath of + Nothing -> putStrLn "No folder selected" + Just dir -> putStrLn $ "Selected folder: " ++ dir - mapM_ putStrLn files - - - - - applicationRun app Nothing threadDelay 30000000000 diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 1b3398f..cc60149 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -1,6 +1,7 @@ module Wazahs ( listFiles, - selectFolder + selectFolder, + getFolderAsync ) where -- imports @@ -11,13 +12,14 @@ import GI.Gio hiding (Application) import qualified GI.Gtk as GTK import Control.Monad (when, void, mzero, guard) import Data.Foldable (for_) -import System.Directory (doesDirectoryExist, listDirectory) -import System.FilePath (()) +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 (getArgs) -import System.FilePath (takeExtension) +import Control.Concurrent +import System.IO (writeFile) import Conduit @@ -38,5 +40,57 @@ selectFolder fd w k = p <$ (liftIO (doesDirectoryExist p) >>= guard) k mbPath --- compose the two here: [TODO] +-- 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 + +-- 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) From 874ece8deb19e762080de81941cbf6ecf9f02787 Mon Sep 17 00:00:00 2001 From: hashirama Date: Tue, 16 Sep 2025 22:20:17 -0400 Subject: [PATCH 16/23] finish file handling --- examples/Main.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 36ac93e..a43e463 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -12,7 +12,8 @@ import Wazahs import Control.Concurrent import System.FilePath (()) import System.IO (writeFile) - +import Control.Concurrent.STM +import System.Directory main :: IO () @@ -26,9 +27,20 @@ main = do home <- getHomeDirectory let cfg = home ".local" "share" "wazajisho" "config" + filesVar <- newTVarIO [] getFolderAsync fd w cfg $ \mPath -> case mPath of - Nothing -> putStrLn "No folder selected" - Just dir -> putStrLn $ "Selected folder: " ++ dir + Nothing -> putStrLn "No folder selected" + Just dir -> do + fs <- listFiles dir + atomically $ writeTVar filesVar fs -- store for later + -- putStrLn "Selected folder files:" + -- mapM_ putStrLn fs + + + -- here we read the files + currentFiles <- readTVarIO filesVar + mapM_ putStrLn currentFiles + applicationRun app Nothing From 6bd7f81c1b31af8f4319d282889bbf7b56eb6267 Mon Sep 17 00:00:00 2001 From: hashirama Date: Tue, 16 Sep 2025 22:30:26 -0400 Subject: [PATCH 17/23] make the program close after selecting the dictionary folder --- examples/Main.hs | 4 +--- src/Wazahs.hs | 15 +++++++++++++-- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index a43e463..27c8b82 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -30,11 +30,9 @@ main = do filesVar <- newTVarIO [] getFolderAsync fd w cfg $ \mPath -> case mPath of Nothing -> putStrLn "No folder selected" - Just dir -> do + Just dir -> do -- there's a bug, in which if the folder is selected with the dialog, nothing will happen. fs <- listFiles dir atomically $ writeTVar filesVar fs -- store for later - -- putStrLn "Selected folder files:" - -- mapM_ putStrLn fs -- here we read the files diff --git a/src/Wazahs.hs b/src/Wazahs.hs index cc60149..bac4b41 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -17,11 +17,12 @@ import System.FilePath import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Conduit -import System.Environment (getArgs) +import System.Environment import Control.Concurrent import System.IO (writeFile) import Conduit - +import System.Process +import System.Exit -- | Recursively list all files in the given directory with .mdx extension. listFiles :: FilePath -> IO [FilePath] @@ -69,6 +70,15 @@ getFolderBlocking fd w configFile = do 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 @@ -93,4 +103,5 @@ getFolderAsync fd w configFile k = do createDirectoryIfMissing True (takeDirectory configFile) writeFile configFile p k (Just p) + restartProgram From 1e3e93507f9244c0fb32b275c4fd9979aa3b7b7a Mon Sep 17 00:00:00 2001 From: hashirama Date: Wed, 17 Sep 2025 22:22:12 -0400 Subject: [PATCH 18/23] start working on icon toolbar --- examples/Main.hs | 124 +++++++++++++++++++++++++++++++++++++++++------ src/Wazahs.hs | 80 +++++++++++++++++++++++++++++- 2 files changed, 188 insertions(+), 16 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 27c8b82..8b59164 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -6,14 +6,18 @@ {-# LANGUAGE BlockArguments #-} import GI.Gtk -import qualified GI.Gtk as 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 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 () @@ -21,25 +25,115 @@ main = do app <- new Application [] onApplicationActivate app $ do - w <- new GI.Gtk.ApplicationWindow [#application := app, #title := "Wazajisho"] - fd <- GTK.fileDialogNew + 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 w cfg $ \mPath -> case mPath of - Nothing -> putStrLn "No folder selected" - Just dir -> do -- there's a bug, in which if the folder is selected with the dialog, nothing will happen. - fs <- listFiles dir - atomically $ writeTVar filesVar fs -- store for later - - - -- here we read the files - currentFiles <- readTVarIO filesVar - mapM_ putStrLn currentFiles + iconsVar <- 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 + writeTVar iconsVar (findIcons fs) + -- read it right back out and print + newIcons <- readTVarIO iconsVar + putStrLn $ "After write, iconsVar has: " ++ show newIcons + + + + rootVBox <- Gtk.boxNew Gtk.OrientationVertical 6 + topHBox <- Gtk.boxNew Gtk.OrientationHorizontal 6 + Gtk.widgetSetHexpand topHBox True + + + -- 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 + 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 + mainBox <- Gtk.boxNew Gtk.OrientationVertical 0 + +-- 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 - threadDelay 30000000000 + return () diff --git a/src/Wazahs.hs b/src/Wazahs.hs index bac4b41..55e6e26 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-} module Wazahs ( listFiles, selectFolder, - getFolderAsync + getFolderAsync, + createIconToolbar, + findIcons ) where -- imports @@ -10,6 +13,7 @@ import qualified Data.Conduit.Combinators as CC import GI.Gtk import GI.Gio hiding (Application) import qualified GI.Gtk as GTK +import qualified GI.Gtk as Gtk import Control.Monad (when, void, mzero, guard) import Data.Foldable (for_) import System.Directory @@ -22,6 +26,8 @@ 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. @@ -105,3 +111,75 @@ getFolderAsync fd w configFile k = do 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 From 69b12db443b914de56f9467fdb38effcdd7cd3d8 Mon Sep 17 00:00:00 2001 From: hashirama Date: Wed, 17 Sep 2025 22:50:28 -0400 Subject: [PATCH 19/23] finish icontoolbar --- examples/Main.hs | 9 ++++----- src/Wazahs.hs | 13 +++++++++++-- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 8b59164..38aa82e 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -52,19 +52,18 @@ main = do 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 @@ -74,7 +73,7 @@ main = do WK.webViewLoadHtml webview content (Nothing :: Maybe T.Text) -- Main vertical box - mainBox <- Gtk.boxNew Gtk.OrientationVertical 0 + -- Toolbar diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 55e6e26..59d44d1 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -4,13 +4,15 @@ module Wazahs ( selectFolder, getFolderAsync, createIconToolbar, - findIcons + findIcons, + (<@) ) where -- imports import qualified Data.Conduit.Combinators as CC -import GI.Gtk +import GI.Gtk +import GI.GLib (mainContextInvokeFull) import GI.Gio hiding (Application) import qualified GI.Gtk as GTK import qualified GI.Gtk as Gtk @@ -183,3 +185,10 @@ createIconToolbar iconPaths = do -- 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 From 197c806412cfb6e5d8fe2bdf729e0ba73ff929df Mon Sep 17 00:00:00 2001 From: hashirama Date: Wed, 17 Sep 2025 23:02:52 -0400 Subject: [PATCH 20/23] removed unused code --- examples/Main.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 38aa82e..5b95fa7 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -32,7 +32,6 @@ main = do let cfg = home ".local" "share" "wazajisho" "config" filesVar <- newTVarIO [] - iconsVar <- newTVarIO [] getFolderAsync fd window cfg $ \mPath -> case mPath of Nothing -> putStrLn "Callback: no folder selected" @@ -42,12 +41,7 @@ main = do putStrLn $ "Callback: listFiles found: " ++ show fs atomically $ do writeTVar filesVar fs - writeTVar iconsVar (findIcons fs) - -- read it right back out and print - newIcons <- readTVarIO iconsVar - putStrLn $ "After write, iconsVar has: " ++ show newIcons - - + rootVBox <- Gtk.boxNew Gtk.OrientationVertical 6 topHBox <- Gtk.boxNew Gtk.OrientationHorizontal 6 From eb59d860efec85c1713cb0757637527b94c9d2a2 Mon Sep 17 00:00:00 2001 From: hashirama Date: Sun, 9 Nov 2025 14:54:56 -0400 Subject: [PATCH 21/23] add helpers for creating Dialogs --- src/Wazahs.hs | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 59d44d1..b08b854 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE OverloadedStrings, OverloadedLabels, ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Wazahs ( listFiles, selectFolder, @@ -16,6 +20,15 @@ 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 @@ -192,3 +205,44 @@ infixr 0 <@ (<@) 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.ApplicationWindow -> IO () +setWindowAsDialog win = do + mSurface <- #getSurface win + case mSurface of + Just surface -> do + -- Cast to X11 surface & display + mX11Surface <- castTo GdkX11.X11Surface surface + display <- Gdk.surfaceGetDisplay surface + mX11Display <- castTo GdkX11.X11Display display + + case (mX11Display, mX11Surface) of + (Just _gdkX11Disp, Just x11Surf) -> do + -- get window XID + xidCULong <- GdkX11.x11SurfaceGetXid x11Surf + + -- open a short-lived X11 connection (Xlib Display*) + dpy <- openDisplay "" + + -- intern atoms and set property as ATOM (EWMH) + 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 :: Graphics.X11.Xlib.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.ApplicationWindow -> IO SignalHandlerId +attachDialogOnRealize win = on win #realize (setWindowAsDialog win) From c6f5a8fd39413ba43907424a3ae1201d438c43e1 Mon Sep 17 00:00:00 2001 From: hashirama Date: Sun, 9 Nov 2025 14:56:59 -0400 Subject: [PATCH 22/23] export function --- src/Wazahs.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Wazahs.hs b/src/Wazahs.hs index b08b854..2320295 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -9,7 +9,8 @@ module Wazahs ( getFolderAsync, createIconToolbar, findIcons, - (<@) + (<@), + attachDialogOnRealize ) where -- imports From 8bb30d4ed34066525ae5558d4c5b8a62c6e488bf Mon Sep 17 00:00:00 2001 From: hashirama Date: Sun, 9 Nov 2025 15:13:11 -0400 Subject: [PATCH 23/23] polymorphic approach --- src/Wazahs.hs | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/src/Wazahs.hs b/src/Wazahs.hs index 2320295..2f6dc0c 100644 --- a/src/Wazahs.hs +++ b/src/Wazahs.hs @@ -210,31 +210,32 @@ infixr 0 <@ -- | 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.ApplicationWindow -> IO () +setWindowAsDialog :: Gtk.IsWindow w => w -> IO () setWindowAsDialog win = do - mSurface <- #getSurface win + -- 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 -> do - -- Cast to X11 surface & display - mX11Surface <- castTo GdkX11.X11Surface surface + 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 + mX11Display <- (castTo GdkX11.X11Display display) :: IO (Maybe GdkX11.X11Display) case (mX11Display, mX11Surface) of (Just _gdkX11Disp, Just x11Surf) -> do - -- get window XID + -- get window XID and set ATOM via X11 xidCULong <- GdkX11.x11SurfaceGetXid x11Surf - -- open a short-lived X11 connection (Xlib Display*) dpy <- openDisplay "" - - -- intern atoms and set property as ATOM (EWMH) 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 :: Graphics.X11.Xlib.Window + let winX :: Window winX = fromIntegral (xidCULong :: CULong) void $ xChangeProperty dpy winX atomType atomAtom 32 propModeReplace (castPtr ptr) 1 flush dpy @@ -245,5 +246,7 @@ setWindowAsDialog win = do -- | Attach setting the dialog atom to the window's #realize signal. -- Returns the SignalHandlerId so you can disconnect if needed. -attachDialogOnRealize :: Gtk.ApplicationWindow -> IO SignalHandlerId -attachDialogOnRealize win = on win #realize (setWindowAsDialog win) +attachDialogOnRealize :: Gtk.IsWindow w => w -> IO SignalHandlerId +attachDialogOnRealize win = do + wnd <- Gtk.toWindow win + on wnd #realize (setWindowAsDialog win)