266 lines
9.4 KiB
Haskell
266 lines
9.4 KiB
Haskell
{-# 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
|
|
-- 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 ()
|