haskell-examples/hardcodedCss.hs

{-# 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


createScrollableToolbar :: [FilePath] -> IO Gtk.Widget
createScrollableToolbar iconPaths = do
    -- Create scrolling container with infinite horizontal space
    scrolled <- Gtk.scrolledWindowNew
    Gtk.setScrolledWindowHscrollbarPolicy scrolled Gtk.PolicyTypeNever
    
    
    -- Create toolbar with subtle styling
    toolbar <- Gtk.boxNew Gtk.OrientationHorizontal 5  -- Reduced spacing
    adjustment <- new Gtk.Adjustment [#value := 50, #lower := 0, #upper := 100, #stepIncrement := 1] 
    Gtk.scrolledWindowSetHadjustment scrolled (Just adjustment)
    

    -- Add modern visual effects
    cssProvider <- Gtk.cssProviderNew
    Gtk.cssProviderLoadFromString cssProvider $ T.pack $
        ".glass-button {"
        ++ "border: 1px solid rgba(255,255,255,0.2);"  -- Thin white border
        ++ "background-color: rgba(255,255,255,0.1);"   -- Glass background
        ++ "border-radius: 4px;"                        -- Rounded corners
        ++ "backdrop-filter: blur(2px);"                 -- Blur effect
        ++ "transition: all 0.2s ease;"
        ++ "}"
        ++ ".glass-button:hover {"
        ++ "background-color: rgba(255,255,255,0.2);"
        ++ "}"

    mapM_ (\path -> do
        -- Create image with consistent aspect ratio
        icon <- Gtk.imageNewFromFile path
        Gtk.widgetSetSizeRequest icon 64 64
        Gtk.widgetSetHalign icon Gtk.AlignCenter
        
        
        -- Create styled button container
        btn <- Gtk.buttonNew
        Gtk.widgetAddCssClass btn "glass-button"
        Gtk.widgetSetSizeRequest btn 80 (-1)
        Gtk.buttonSetChild btn (Just icon)
        
        -- Apply CSS styling
        context <- Gtk.widgetGetStyleContext btn
        Gtk.styleContextAddProvider context cssProvider 800  -- High priority
        

            
        Gtk.boxAppend toolbar btn
        ) iconPaths
    
    Gtk.scrolledWindowSetChild scrolled (Just toolbar)
    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
        outer_toolbar <- new Gtk.Box [#orientation := Gtk.OrientationHorizontal, #spacing := 20,
                            #baselinePosition := Gtk.BaselinePositionTop,
                            #halign := Gtk.AlignFill,
                            #hexpand := True, #widthRequest := 300,
                            #marginTop := 10, #marginEnd := 10, #marginStart := 15]
  
        window <- Gtk.applicationWindowNew app
        Gtk.windowSetTitle window (Just "Dictionary Toolbar")
        Gtk.windowSetDefaultSize window 800 100
             
        
        window <- Gtk.applicationWindowNew app
        toolbar <- createScrollableToolbar icons
        #append outer_toolbar toolbar
        Gtk.windowSetChild window (Just outer_toolbar)        

        Gtk.widgetShow window
    
    _ <- applicationRun app Nothing
    return ()