Update Main.hs
This commit is contained in:
parent
37c8456322
commit
015389e484
1 changed files with 317 additions and 79 deletions
402
Main.hs
402
Main.hs
|
|
@ -1,105 +1,343 @@
|
|||
{-# 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.WebKit.Objects.WebView as WK
|
||||
|
||||
module Main where
|
||||
|
||||
import qualified GI.Gtk as Gtk
|
||||
import GI.Gio
|
||||
import qualified Data.Text as T
|
||||
import GI.Gtk (Grid(..), Image(..), Orientable(..))
|
||||
import GI.Gio
|
||||
import Control.Monad (void)
|
||||
|
||||
createWordLabel :: T.Text -> IO Gtk.Widget
|
||||
createWordLabel word = do
|
||||
label <- Gtk.labelNew Nothing
|
||||
let markup = "<span size=\"25pt\">" <> word <> "</span>"
|
||||
Gtk.labelSetMarkup label markup
|
||||
motionController <- Gtk.eventControllerMotionNew
|
||||
Gtk.widgetAddController label motionController
|
||||
void $ Gtk.on motionController #enter $ \_ _ -> putStrLn (T.unpack word)
|
||||
Gtk.labelSetWrap label True -- allow it to break lines
|
||||
Gtk.toWidget label
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
|
||||
|
||||
updateUI :: Gtk.Box -> [String] -> IO ()
|
||||
updateUI outerBox sentence = do
|
||||
-- Remove all existing children from outerBox
|
||||
let removeChildren widget = do
|
||||
mChild <- Gtk.widgetGetFirstChild widget
|
||||
case mChild of
|
||||
Just child -> do
|
||||
Gtk.boxRemove outerBox child
|
||||
removeChildren widget
|
||||
Nothing -> return ()
|
||||
removeChildren outerBox
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- Create a new sentence box
|
||||
sentenceBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
|
||||
Gtk.widgetSetHalign sentenceBox Gtk.AlignCenter
|
||||
import qualified GI.Gtk as Gtk
|
||||
import GI.Gtk (AttrOp((:=)))
|
||||
import Data.Text (Text)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
let tokens = map T.pack sentence
|
||||
widgets <- mapM createWordLabel tokens
|
||||
mapM_ (Gtk.boxAppend sentenceBox) widgets
|
||||
|
||||
Gtk.boxAppend outerBox sentenceBox
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- Gtk.applicationNew (Just "com.example.YomichanHover") []
|
||||
|
||||
void $ onApplicationActivate app $ do
|
||||
window <- Gtk.applicationWindowNew app
|
||||
Gtk.windowSetTitle window (Just "Yomichan Hover")
|
||||
Gtk.windowSetDefaultSize window 400 150
|
||||
|
||||
finalBox <- Gtk.boxNew Gtk.OrientationVertical 0
|
||||
|
||||
Gtk.windowSetChild window (Just finalBox)
|
||||
|
||||
|
||||
Gtk.windowSetChild window (Just finalBox)
|
||||
|
||||
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]
|
||||
|
||||
-- Input field
|
||||
entry <- Gtk.entryNew
|
||||
|
||||
Gtk.editableSetEditable entry True
|
||||
#setHexpand entry True -- expand the searchEntry to fill the width
|
||||
searchButton <- new Gtk.Button [#label := "Search"]
|
||||
|
||||
#append searchBar entry
|
||||
#append searchBar searchButton
|
||||
|
||||
#append finalBox searchBar
|
||||
|
||||
|
||||
-- Function that builds the cache
|
||||
allFiles <- scanDirectoryRecursivelyStr "/mnt/Data/Japanese_Resources/Dictionaries/Own_Collection/"
|
||||
|
||||
-- Outer box (centers content)
|
||||
outerBox <- new Gtk.Box [#orientation := Gtk.OrientationVertical, #spacing := 20,
|
||||
#baselinePosition := Gtk.BaselinePositionTop,
|
||||
#hexpand := True, #widthRequest := 300,
|
||||
#marginTop := 15, #marginEnd := 15, #marginStart := 15]
|
||||
|
||||
Gtk.widgetSetHalign outerBox Gtk.AlignStart
|
||||
Gtk.widgetSetValign outerBox Gtk.AlignStart
|
||||
Gtk.boxAppend finalBox outerBox
|
||||
-- Filter files with '.mdx' extension
|
||||
let mdxFiles = filterMdx allFiles ".mdx"
|
||||
|
||||
-- Group the files by their directories concurrently
|
||||
groupedFiles <- groupFilesByDirectory mdxFiles allFiles
|
||||
|
||||
|
||||
-- Connect signal to update UI when pressing Enter
|
||||
void $ Gtk.on entry #activate $ do
|
||||
text <- Gtk.editableGetText entry
|
||||
let sentence = words (T.unpack text)
|
||||
updateUI outerBox sentence
|
||||
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
|
||||
|
||||
|
||||
|
||||
void $ Gtk.on window #closeRequest $ do
|
||||
applicationQuit app
|
||||
return False
|
||||
let htmlFilePath = "/tmp/index.html"
|
||||
content <- TIO.readFile htmlFilePath
|
||||
webview <- WK.webViewNew
|
||||
|
||||
Gtk.widgetSetVisible window True
|
||||
-- Load HTML content
|
||||
WK.webViewLoadHtml webview content (Nothing :: Maybe T.Text)
|
||||
|
||||
-- Main vertical box
|
||||
mainBox <- Gtk.boxNew Gtk.OrientationVertical 0
|
||||
|
||||
-- Toolbar
|
||||
toolbar <- createIconToolbar icons
|
||||
Gtk.boxAppend mainBox 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 := ("日本語の例文です" :: 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
|
||||
|
||||
-- Window
|
||||
Gtk.windowSetChild window (Just mainBox)
|
||||
Gtk.widgetShow window
|
||||
|
||||
_ <- applicationRun app Nothing
|
||||
return ()
|
||||
|
||||
_ <- applicationRun app Nothing
|
||||
return ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue